Theory Transactions
section‹Protocol Transactions›
theory Transactions
imports
Stateful_Protocol_Composition_and_Typing.Typed_Model
Stateful_Protocol_Composition_and_Typing.Labeled_Stateful_Strands
begin
subsection ‹Definitions›
datatype 'b prot_atom =
is_Atom: Atom 'b
| Value
| SetType
| AttackType
| Bottom
| OccursSecType
datatype ('a,'b,'c) prot_fun =
Fu (the_Fu: 'a)
| Set (the_Set: 'c)
| Val (the_Val: "nat × bool")
| Abs (the_Abs: "'c set")
| Pair
| Attack nat
| PubConstAtom 'b nat
| PubConstSetType nat
| PubConstAttackType nat
| PubConstBottom nat
| PubConstOccursSecType nat
| OccursFact
| OccursSec
definition "is_Fun_Set t ≡ is_Fun t ∧ args t = [] ∧ is_Set (the_Fun t)"
abbreviation occurs where
"occurs t ≡ Fun OccursFact [Fun OccursSec [], t]"
type_synonym ('a,'b,'c) prot_term_type = "(('a,'b,'c) prot_fun,'b prot_atom) term_type"
type_synonym ('a,'b,'c) prot_var = "('a,'b,'c) prot_term_type × nat"
type_synonym ('a,'b,'c) prot_term = "(('a,'b,'c) prot_fun,('a,'b,'c) prot_var) term"
type_synonym ('a,'b,'c) prot_terms = "('a,'b,'c) prot_term set"
type_synonym ('a,'b,'c) prot_subst = "(('a,'b,'c) prot_fun, ('a,'b,'c) prot_var) subst"
type_synonym ('a,'b,'c,'d) prot_strand_step =
"(('a,'b,'c) prot_fun, ('a,'b,'c) prot_var, 'd) labeled_stateful_strand_step"
type_synonym ('a,'b,'c,'d) prot_strand = "('a,'b,'c,'d) prot_strand_step list"
type_synonym ('a,'b,'c,'d) prot_constr = "('a,'b,'c,'d) prot_strand_step list"
datatype ('a,'b,'c,'d) prot_transaction =
Transaction
(transaction_fresh: "('a,'b,'c) prot_var list")
(transaction_receive: "('a,'b,'c,'d) prot_strand")
(transaction_selects: "('a,'b,'c,'d) prot_strand")
(transaction_checks: "('a,'b,'c,'d) prot_strand")
(transaction_updates: "('a,'b,'c,'d) prot_strand")
(transaction_send: "('a,'b,'c,'d) prot_strand")
definition transaction_strand where
"transaction_strand T ≡
transaction_receive T@transaction_selects T@transaction_checks T@
transaction_updates T@transaction_send T"
fun transaction_proj where
"transaction_proj l (Transaction A B C D E F) = (
let f = proj l
in Transaction A (f B) (f C) (f D) (f E) (f F))"
fun transaction_star_proj where
"transaction_star_proj (Transaction A B C D E F) = (
let f = filter is_LabelS
in Transaction A (f B) (f C) (f D) (f E) (f F))"
abbreviation fv_transaction where
"fv_transaction T ≡ fv⇩l⇩s⇩s⇩t (transaction_strand T)"
abbreviation bvars_transaction where
"bvars_transaction T ≡ bvars⇩l⇩s⇩s⇩t (transaction_strand T)"
abbreviation vars_transaction where
"vars_transaction T ≡ vars⇩l⇩s⇩s⇩t (transaction_strand T)"
abbreviation trms_transaction where
"trms_transaction T ≡ trms⇩l⇩s⇩s⇩t (transaction_strand T)"
abbreviation setops_transaction where
"setops_transaction T ≡ setops⇩s⇩s⇩t (unlabel (transaction_strand T))"
definition wellformed_transaction where
"wellformed_transaction T ≡
list_all is_Receive (unlabel (transaction_receive T)) ∧
list_all is_Assignment (unlabel (transaction_selects T)) ∧
list_all is_Check (unlabel (transaction_checks T)) ∧
list_all is_Update (unlabel (transaction_updates T)) ∧
list_all is_Send (unlabel (transaction_send T)) ∧
set (transaction_fresh T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪ fv⇩l⇩s⇩s⇩t (transaction_send T) ∧
set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_receive T) = {} ∧
set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_selects T) = {} ∧
fv_transaction T ∩ bvars_transaction T = {} ∧
fv⇩l⇩s⇩s⇩t (transaction_checks T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T) ∧
fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪ fv⇩l⇩s⇩s⇩t (transaction_send T) - set (transaction_fresh T)
⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T) ∧
(∀x ∈ set (unlabel (transaction_selects T)).
is_Equality x ⟶ fv (the_rhs x) ⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T))"
type_synonym ('a,'b,'c,'d) prot = "('a,'b,'c,'d) prot_transaction list"
abbreviation Var_Value_term ("⟨_⟩⇩v") where
"⟨n⟩⇩v ≡ Var (Var Value, n)::('a,'b,'c) prot_term"
abbreviation Fun_Fu_term ("⟨_ _⟩⇩t") where
"⟨f T⟩⇩t ≡ Fun (Fu f) T::('a,'b,'c) prot_term"
abbreviation Fun_Fu_const_term ("⟨_⟩⇩c") where
"⟨c⟩⇩c ≡ Fun (Fu c) []::('a,'b,'c) prot_term"
abbreviation Fun_Set_const_term ("⟨_⟩⇩s") where
"⟨f⟩⇩s ≡ Fun (Set f) []::('a,'b,'c) prot_term"
abbreviation Fun_Abs_const_term ("⟨_⟩⇩a") where
"⟨a⟩⇩a ≡ Fun (Abs a) []::('a,'b,'c) prot_term"
abbreviation Fun_Attack_const_term ("attack⟨_⟩") where
"attack⟨n⟩ ≡ Fun (Attack n) []::('a,'b,'c) prot_term"
abbreviation prot_transaction1 ("transaction⇩1 _ _ new _ _ _") where
"transaction⇩1 (S1::('a,'b,'c,'d) prot_strand) S2 new (B::('a,'b,'c) prot_term list) S3 S4
≡ Transaction (map the_Var B) S1 [] S2 S3 S4"
abbreviation prot_transaction2 ("transaction⇩2 _ _ _ _") where
"transaction⇩2 (S1::('a,'b,'c,'d) prot_strand) S2 S3 S4
≡ Transaction [] S1 [] S2 S3 S4"
subsection ‹Lemmata›
lemma prot_atom_UNIV:
"(UNIV::'b prot_atom set) = range Atom ∪ {Value, SetType, AttackType, Bottom, OccursSecType}"
proof -
have "a ∈ range Atom ∨ a = Value ∨ a = SetType ∨ a = AttackType ∨ a = Bottom ∨ a = OccursSecType"
for a::"'b prot_atom"
by (cases a) auto
thus ?thesis by auto
qed
instance prot_atom::(finite) finite
by intro_classes (simp add: prot_atom_UNIV)
instantiation prot_atom::(enum) enum
begin
definition "enum_prot_atom == map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType]"
definition "enum_all_prot_atom P == list_all P (map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType])"
definition "enum_ex_prot_atom P == list_ex P (map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType])"
instance
proof intro_classes
have *: "set (map Atom (enum_class.enum::'a list)) = range Atom"
"distinct (enum_class.enum::'a list)"
using UNIV_enum enum_distinct by auto
show "(UNIV::'a prot_atom set) = set enum_class.enum"
using *(1) by (simp add: prot_atom_UNIV enum_prot_atom_def)
have "set (map Atom enum_class.enum) ∩ set [Value, SetType, AttackType, Bottom, OccursSecType] = {}" by auto
moreover have "inj_on Atom (set (enum_class.enum::'a list))" unfolding inj_on_def by auto
hence "distinct (map Atom (enum_class.enum::'a list))" by (metis *(2) distinct_map)
ultimately show "distinct (enum_class.enum::'a prot_atom list)" by (simp add: enum_prot_atom_def)
have "Ball UNIV P ⟷ Ball (range Atom) P ∧ Ball {Value, SetType, AttackType, Bottom, OccursSecType} P"
for P::"'a prot_atom ⇒ bool"
by (metis prot_atom_UNIV UNIV_I UnE)
thus "enum_class.enum_all P = Ball (UNIV::'a prot_atom set) P" for P
using *(1) Ball_set[of "map Atom enum_class.enum" P]
by (auto simp add: enum_all_prot_atom_def)
have "Bex UNIV P ⟷ Bex (range Atom) P ∨ Bex {Value, SetType, AttackType, Bottom, OccursSecType} P"
for P::"'a prot_atom ⇒ bool"
by (metis prot_atom_UNIV UNIV_I UnE)
thus "enum_class.enum_ex P = Bex (UNIV::'a prot_atom set) P" for P
using *(1) Bex_set[of "map Atom enum_class.enum" P]
by (auto simp add: enum_ex_prot_atom_def)
qed
end
lemma wellformed_transaction_cases:
assumes "wellformed_transaction T"
shows
"(l,x) ∈ set (transaction_receive T) ⟹ ∃t. x = receive⟨t⟩" (is "?A ⟹ ?A'")
"(l,x) ∈ set (transaction_selects T) ⟹
(∃t s. x = ⟨t := s⟩) ∨ (∃t s. x = select⟨t,s⟩)" (is "?B ⟹ ?B'")
"(l,x) ∈ set (transaction_checks T) ⟹
(∃t s. x = ⟨t == s⟩) ∨ (∃t s. x = ⟨t in s⟩) ∨ (∃X F G. x = ∀X⟨∨≠: F ∨∉: G⟩)" (is "?C ⟹ ?C'")
"(l,x) ∈ set (transaction_updates T) ⟹
(∃t s. x = insert⟨t,s⟩) ∨ (∃t s. x = delete⟨t,s⟩)" (is "?D ⟹ ?D'")
"(l,x) ∈ set (transaction_send T) ⟹ ∃t. x = send⟨t⟩" (is "?E ⟹ ?E'")
proof -
have a:
"list_all is_Receive (unlabel (transaction_receive T))"
"list_all is_Assignment (unlabel (transaction_selects T))"
"list_all is_Check (unlabel (transaction_checks T))"
"list_all is_Update (unlabel (transaction_updates T))"
"list_all is_Send (unlabel (transaction_send T))"
using assms unfolding wellformed_transaction_def by metis+
note b = Ball_set unlabel_in
note c = stateful_strand_step.collapse
show "?A ⟹ ?A'" by (metis (mono_tags, lifting) a(1) b c(2))
show "?B ⟹ ?B'" by (metis (mono_tags, lifting) a(2) b c(3,6))
show "?C ⟹ ?C'" by (metis (mono_tags, lifting) a(3) b c(3,6,7))
show "?D ⟹ ?D'" by (metis (mono_tags, lifting) a(4) b c(4,5))
show "?E ⟹ ?E'" by (metis (mono_tags, lifting) a(5) b c(1))
qed
lemma wellformed_transaction_unlabel_cases:
assumes "wellformed_transaction T"
shows
"x ∈ set (unlabel (transaction_receive T)) ⟹ ∃t. x = receive⟨t⟩" (is "?A ⟹ ?A'")
"x ∈ set (unlabel (transaction_selects T)) ⟹
(∃t s. x = ⟨t := s⟩) ∨ (∃t s. x = select⟨t,s⟩)" (is "?B ⟹ ?B'")
"x ∈ set (unlabel (transaction_checks T)) ⟹
(∃t s. x = ⟨t == s⟩) ∨ (∃t s. x = ⟨t in s⟩) ∨ (∃X F G. x = ∀X⟨∨≠: F ∨∉: G⟩)"
(is "?C ⟹ ?C'")
"x ∈ set (unlabel (transaction_updates T)) ⟹
(∃t s. x = insert⟨t,s⟩) ∨ (∃t s. x = delete⟨t,s⟩)" (is "?D ⟹ ?D'")
"x ∈ set (unlabel (transaction_send T)) ⟹ ∃t. x = send⟨t⟩" (is "?E ⟹ ?E'")
proof -
have a:
"list_all is_Receive (unlabel (transaction_receive T))"
"list_all is_Assignment (unlabel (transaction_selects T))"
"list_all is_Check (unlabel (transaction_checks T))"
"list_all is_Update (unlabel (transaction_updates T))"
"list_all is_Send (unlabel (transaction_send T))"
using assms unfolding wellformed_transaction_def by metis+
note b = Ball_set
note c = stateful_strand_step.collapse
show "?A ⟹ ?A'" by (metis (mono_tags, lifting) a(1) b c(2))
show "?B ⟹ ?B'" by (metis (mono_tags, lifting) a(2) b c(3,6))
show "?C ⟹ ?C'" by (metis (mono_tags, lifting) a(3) b c(3,6,7))
show "?D ⟹ ?D'" by (metis (mono_tags, lifting) a(4) b c(4,5))
show "?E ⟹ ?E'" by (metis (mono_tags, lifting) a(5) b c(1))
qed
lemma transaction_strand_subsets[simp]:
"set (transaction_receive T) ⊆ set (transaction_strand T)"
"set (transaction_selects T) ⊆ set (transaction_strand T)"
"set (transaction_checks T) ⊆ set (transaction_strand T)"
"set (transaction_updates T) ⊆ set (transaction_strand T)"
"set (transaction_send T) ⊆ set (transaction_strand T)"
"set (unlabel (transaction_receive T)) ⊆ set (unlabel (transaction_strand T))"
"set (unlabel (transaction_selects T)) ⊆ set (unlabel (transaction_strand T))"
"set (unlabel (transaction_checks T)) ⊆ set (unlabel (transaction_strand T))"
"set (unlabel (transaction_updates T)) ⊆ set (unlabel (transaction_strand T))"
"set (unlabel (transaction_send T)) ⊆ set (unlabel (transaction_strand T))"
unfolding transaction_strand_def unlabel_def by force+
lemma transaction_strand_subst_subsets[simp]:
"set (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ) ⊆ set (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
"set (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ) ⊆ set (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
"set (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ) ⊆ set (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
"set (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ) ⊆ set (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
"set (transaction_send T ⋅⇩l⇩s⇩s⇩t θ) ⊆ set (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
"set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)) ⊆ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
"set (unlabel (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ)) ⊆ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
"set (unlabel (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ)) ⊆ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
"set (unlabel (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ)) ⊆ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
"set (unlabel (transaction_send T ⋅⇩l⇩s⇩s⇩t θ)) ⊆ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
unfolding transaction_strand_def unlabel_def subst_apply_labeled_stateful_strand_def by force+
lemma transaction_dual_subst_unfold:
"unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)) =
unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))@
unlabel (dual⇩l⇩s⇩s⇩t (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ))@
unlabel (dual⇩l⇩s⇩s⇩t (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ))@
unlabel (dual⇩l⇩s⇩s⇩t (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ))@
unlabel (dual⇩l⇩s⇩s⇩t (transaction_send T ⋅⇩l⇩s⇩s⇩t θ))"
by (simp add: transaction_strand_def unlabel_append dual⇩l⇩s⇩s⇩t_append subst_lsst_append)
lemma trms_transaction_unfold:
"trms_transaction T =
trms⇩l⇩s⇩s⇩t (transaction_receive T) ∪ trms⇩l⇩s⇩s⇩t (transaction_selects T) ∪
trms⇩l⇩s⇩s⇩t (transaction_checks T) ∪ trms⇩l⇩s⇩s⇩t (transaction_updates T) ∪
trms⇩l⇩s⇩s⇩t (transaction_send T)"
by (metis trms⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def)
lemma trms_transaction_subst_unfold:
"trms⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ) =
trms⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ) ∪ trms⇩l⇩s⇩s⇩t (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ) ∪
trms⇩l⇩s⇩s⇩t (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ) ∪ trms⇩l⇩s⇩s⇩t (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ) ∪
trms⇩l⇩s⇩s⇩t (transaction_send T ⋅⇩l⇩s⇩s⇩t θ)"
by (metis trms⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
lemma vars_transaction_unfold:
"vars_transaction T =
vars⇩l⇩s⇩s⇩t (transaction_receive T) ∪ vars⇩l⇩s⇩s⇩t (transaction_selects T) ∪
vars⇩l⇩s⇩s⇩t (transaction_checks T) ∪ vars⇩l⇩s⇩s⇩t (transaction_updates T) ∪
vars⇩l⇩s⇩s⇩t (transaction_send T)"
by (metis vars⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def)
lemma vars_transaction_subst_unfold:
"vars⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ) =
vars⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ) ∪ vars⇩l⇩s⇩s⇩t (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ) ∪
vars⇩l⇩s⇩s⇩t (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ) ∪ vars⇩l⇩s⇩s⇩t (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ) ∪
vars⇩l⇩s⇩s⇩t (transaction_send T ⋅⇩l⇩s⇩s⇩t θ)"
by (metis vars⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
lemma fv_transaction_unfold:
"fv_transaction T =
fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T) ∪
fv⇩l⇩s⇩s⇩t (transaction_checks T) ∪ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪
fv⇩l⇩s⇩s⇩t (transaction_send T)"
by (metis fv⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def)
lemma fv_transaction_subst_unfold:
"fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ) =
fv⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ) ∪
fv⇩l⇩s⇩s⇩t (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ) ∪ fv⇩l⇩s⇩s⇩t (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ) ∪
fv⇩l⇩s⇩s⇩t (transaction_send T ⋅⇩l⇩s⇩s⇩t θ)"
by (metis fv⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
lemma fv_wellformed_transaction_unfold:
assumes "wellformed_transaction T"
shows "fv_transaction T =
fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T) ∪ set (transaction_fresh T)"
proof -
let ?A = "set (transaction_fresh T)"
let ?B = "fv⇩l⇩s⇩s⇩t (transaction_updates T)"
let ?C = "fv⇩l⇩s⇩s⇩t (transaction_send T)"
let ?D = "fv⇩l⇩s⇩s⇩t (transaction_receive T)"
let ?E = "fv⇩l⇩s⇩s⇩t (transaction_selects T)"
let ?F = "fv⇩l⇩s⇩s⇩t (transaction_checks T)"
have "?A ⊆ ?B ∪ ?C" "?A ∩ ?D = {}" "?A ∩ ?E = {}" "?F ⊆ ?D ∪ ?E" "?B ∪ ?C - ?A ⊆ ?D ∪ ?E"
using assms unfolding wellformed_transaction_def by fast+
thus ?thesis using fv_transaction_unfold by blast
qed
lemma bvars_transaction_unfold:
"bvars_transaction T =
bvars⇩l⇩s⇩s⇩t (transaction_receive T) ∪ bvars⇩l⇩s⇩s⇩t (transaction_selects T) ∪
bvars⇩l⇩s⇩s⇩t (transaction_checks T) ∪ bvars⇩l⇩s⇩s⇩t (transaction_updates T) ∪
bvars⇩l⇩s⇩s⇩t (transaction_send T)"
by (metis bvars⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def)
lemma bvars_transaction_subst_unfold:
"bvars⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ) =
bvars⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ) ∪ bvars⇩l⇩s⇩s⇩t (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ) ∪
bvars⇩l⇩s⇩s⇩t (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ) ∪ bvars⇩l⇩s⇩s⇩t (transaction_updates T ⋅⇩l⇩s⇩s⇩t θ) ∪
bvars⇩l⇩s⇩s⇩t (transaction_send T ⋅⇩l⇩s⇩s⇩t θ)"
by (metis bvars⇩s⇩s⇩t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
lemma bvars_wellformed_transaction_unfold:
assumes "wellformed_transaction T"
shows "bvars_transaction T = bvars⇩l⇩s⇩s⇩t (transaction_checks T)" (is ?A)
and "bvars⇩l⇩s⇩s⇩t (transaction_receive T) = {}" (is ?B)
and "bvars⇩l⇩s⇩s⇩t (transaction_selects T) = {}" (is ?C)
and "bvars⇩l⇩s⇩s⇩t (transaction_updates T) = {}" (is ?D)
and "bvars⇩l⇩s⇩s⇩t (transaction_send T) = {}" (is ?E)
proof -
have 0: "list_all is_Receive (unlabel (transaction_receive T))"
"list_all is_Assignment (unlabel (transaction_selects T))"
"list_all is_Update (unlabel (transaction_updates T))"
"list_all is_Send (unlabel (transaction_send T))"
using assms unfolding wellformed_transaction_def by metis+
have "filter is_NegChecks (unlabel (transaction_receive T)) = []"
"filter is_NegChecks (unlabel (transaction_selects T)) = []"
"filter is_NegChecks (unlabel (transaction_updates T)) = []"
"filter is_NegChecks (unlabel (transaction_send T)) = []"
using list_all_filter_nil[OF 0(1), of is_NegChecks]
list_all_filter_nil[OF 0(2), of is_NegChecks]
list_all_filter_nil[OF 0(3), of is_NegChecks]
list_all_filter_nil[OF 0(4), of is_NegChecks]
stateful_strand_step.distinct_disc(11,21,29,35,39,41)
by blast+
thus ?A ?B ?C ?D ?E
using bvars_transaction_unfold[of T]
bvars⇩s⇩s⇩t_NegChecks[of "unlabel (transaction_receive T)"]
bvars⇩s⇩s⇩t_NegChecks[of "unlabel (transaction_selects T)"]
bvars⇩s⇩s⇩t_NegChecks[of "unlabel (transaction_updates T)"]
bvars⇩s⇩s⇩t_NegChecks[of "unlabel (transaction_send T)"]
by (metis bvars⇩s⇩s⇩t_def UnionE emptyE list.set(1) list.simps(8) subsetI subset_Un_eq sup_commute)+
qed
lemma transaction_strand_memberD[dest]:
assumes "x ∈ set (transaction_strand T)"
shows "x ∈ set (transaction_receive T) ∨ x ∈ set (transaction_selects T) ∨
x ∈ set (transaction_checks T) ∨ x ∈ set (transaction_updates T) ∨
x ∈ set (transaction_send T)"
using assms by (simp add: transaction_strand_def)
lemma transaction_strand_unlabel_memberD[dest]:
assumes "x ∈ set (unlabel (transaction_strand T))"
shows "x ∈ set (unlabel (transaction_receive T)) ∨ x ∈ set (unlabel (transaction_selects T)) ∨
x ∈ set (unlabel (transaction_checks T)) ∨ x ∈ set (unlabel (transaction_updates T)) ∨
x ∈ set (unlabel (transaction_send T))"
using assms by (simp add: unlabel_def transaction_strand_def)
lemma wellformed_transaction_strand_memberD[dest]:
assumes "wellformed_transaction T" and "(l,x) ∈ set (transaction_strand T)"
shows
"x = receive⟨t⟩ ⟹ (l,x) ∈ set (transaction_receive T)" (is "?A ⟹ ?A'")
"x = select⟨t,s⟩ ⟹ (l,x) ∈ set (transaction_selects T)" (is "?B ⟹ ?B'")
"x = ⟨t == s⟩ ⟹ (l,x) ∈ set (transaction_checks T)" (is "?C ⟹ ?C'")
"x = ⟨t in s⟩ ⟹ (l,x) ∈ set (transaction_checks T)" (is "?D ⟹ ?D'")
"x = ∀X⟨∨≠: F ∨∉: G⟩ ⟹ (l,x) ∈ set (transaction_checks T)" (is "?E ⟹ ?E'")
"x = insert⟨t,s⟩ ⟹ (l,x) ∈ set (transaction_updates T)" (is "?F ⟹ ?F'")
"x = delete⟨t,s⟩ ⟹ (l,x) ∈ set (transaction_updates T)" (is "?G ⟹ ?G'")
"x = send⟨t⟩ ⟹ (l,x) ∈ set (transaction_send T)" (is "?H ⟹ ?H'")
proof -
have "(l,x) ∈ set (transaction_receive T) ∨ (l,x) ∈ set (transaction_selects T) ∨
(l,x) ∈ set (transaction_checks T) ∨ (l,x) ∈ set (transaction_updates T) ∨
(l,x) ∈ set (transaction_send T)"
using assms(2) by auto
thus "?A ⟹ ?A'" "?B ⟹ ?B'" "?C ⟹ ?C'" "?D ⟹ ?D'"
"?E ⟹ ?E'" "?F ⟹ ?F'" "?G ⟹ ?G'" "?H ⟹ ?H'"
using wellformed_transaction_cases[OF assms(1)] by fast+
qed
lemma wellformed_transaction_strand_unlabel_memberD[dest]:
assumes "wellformed_transaction T" and "x ∈ set (unlabel (transaction_strand T))"
shows
"x = receive⟨t⟩ ⟹ x ∈ set (unlabel (transaction_receive T))" (is "?A ⟹ ?A'")
"x = select⟨t,s⟩ ⟹ x ∈ set (unlabel (transaction_selects T))" (is "?B ⟹ ?B'")
"x = ⟨t == s⟩ ⟹ x ∈ set (unlabel (transaction_checks T))" (is "?C ⟹ ?C'")
"x = ⟨t in s⟩ ⟹ x ∈ set (unlabel (transaction_checks T))" (is "?D ⟹ ?D'")
"x = ∀X⟨∨≠: F ∨∉: G⟩ ⟹ x ∈ set (unlabel (transaction_checks T))" (is "?E ⟹ ?E'")
"x = insert⟨t,s⟩ ⟹ x ∈ set (unlabel (transaction_updates T))" (is "?F ⟹ ?F'")
"x = delete⟨t,s⟩ ⟹ x ∈ set (unlabel (transaction_updates T))" (is "?G ⟹ ?G'")
"x = send⟨t⟩ ⟹ x ∈ set (unlabel (transaction_send T))" (is "?H ⟹ ?H'")
proof -
have "x ∈ set (unlabel (transaction_receive T)) ∨ x ∈ set (unlabel (transaction_selects T)) ∨
x ∈ set (unlabel (transaction_checks T)) ∨ x ∈ set (unlabel (transaction_updates T)) ∨
x ∈ set (unlabel (transaction_send T))"
using assms(2) by auto
thus "?A ⟹ ?A'" "?B ⟹ ?B'" "?C ⟹ ?C'" "?D ⟹ ?D'"
"?E ⟹ ?E'" "?F ⟹ ?F'" "?G ⟹ ?G'" "?H ⟹ ?H'"
using wellformed_transaction_unlabel_cases[OF assms(1)] by fast+
qed
lemma wellformed_transaction_send_receive_trm_cases:
assumes T: "wellformed_transaction T"
shows "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T) ⟹ receive⟨t⟩ ∈ set (unlabel (transaction_receive T))"
and "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⟹ send⟨t⟩ ∈ set (unlabel (transaction_send T))"
using wellformed_transaction_unlabel_cases(1,5)[OF T]
trms⇩s⇩s⇩t_in[of t "unlabel (transaction_receive T)"]
trms⇩s⇩s⇩t_in[of t "unlabel (transaction_send T)"]
by fastforce+
lemma wellformed_transaction_send_receive_subst_trm_cases:
assumes T: "wellformed_transaction T"
shows "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T) ⋅⇩s⇩e⇩t θ ⟹ receive⟨t⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
and "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t θ ⟹ send⟨t⟩ ∈ set (unlabel (transaction_send T ⋅⇩l⇩s⇩s⇩t θ))"
proof -
assume "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T) ⋅⇩s⇩e⇩t θ"
then obtain s where s: "s ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T)" "t = s ⋅ θ"
by blast
hence "receive⟨s⟩ ∈ set (unlabel (transaction_receive T))"
using wellformed_transaction_send_receive_trm_cases(1)[OF T] by simp
thus "receive⟨t⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
by (metis s(2) unlabel_subst[of _ θ] stateful_strand_step_subst_inI(2))
next
assume "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t θ"
then obtain s where s: "s ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" "t = s ⋅ θ"
by blast
hence "send⟨s⟩ ∈ set (unlabel (transaction_send T))"
using wellformed_transaction_send_receive_trm_cases(2)[OF T] by simp
thus "send⟨t⟩ ∈ set (unlabel (transaction_send T ⋅⇩l⇩s⇩s⇩t θ))"
by (metis s(2) unlabel_subst[of _ θ] stateful_strand_step_subst_inI(1))
qed
lemma wellformed_transaction_send_receive_fv_subset:
assumes T: "wellformed_transaction T"
shows "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T) ⟹ fv t ⊆ fv_transaction T" (is "?A ⟹ ?A'")
and "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⟹ fv t ⊆ fv_transaction T" (is "?B ⟹ ?B'")
proof -
have "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T) ⟹ receive⟨t⟩ ∈ set (unlabel (transaction_strand T))"
"t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⟹ send⟨t⟩ ∈ set (unlabel (transaction_strand T))"
using wellformed_transaction_send_receive_trm_cases[OF T, of t]
unfolding transaction_strand_def by force+
thus "?A ⟹ ?A'" "?B ⟹ ?B'" by (induct "transaction_strand T") auto
qed
lemma dual_wellformed_transaction_ident_cases[dest]:
"list_all is_Assignment (unlabel S) ⟹ dual⇩l⇩s⇩s⇩t S = S"
"list_all is_Check (unlabel S) ⟹ dual⇩l⇩s⇩s⇩t S = S"
"list_all is_Update (unlabel S) ⟹ dual⇩l⇩s⇩s⇩t S = S"
proof (induction S)
case (Cons s S)
obtain l x where s: "s = (l,x)" by moura
{ case 1 thus ?case using Cons s unfolding unlabel_def dual⇩l⇩s⇩s⇩t_def by (cases x) auto }
{ case 2 thus ?case using Cons s unfolding unlabel_def dual⇩l⇩s⇩s⇩t_def by (cases x) auto }
{ case 3 thus ?case using Cons s unfolding unlabel_def dual⇩l⇩s⇩s⇩t_def by (cases x) auto }
qed simp_all
lemma wellformed_transaction_wf⇩s⇩s⇩t:
fixes T::"('a, 'b, 'c, 'd) prot_transaction"
assumes T: "wellformed_transaction T"
shows "wf'⇩s⇩s⇩t (set (transaction_fresh T)) (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)))" (is ?A)
and "fv_transaction T ∩ bvars_transaction T = {}" (is ?B)
and "set (transaction_fresh T) ∩ bvars_transaction T = {}" (is ?C)
proof -
define T1 where "T1 ≡ unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T))"
define T2 where "T2 ≡ unlabel (dual⇩l⇩s⇩s⇩t (transaction_selects T))"
define T3 where "T3 ≡ unlabel (dual⇩l⇩s⇩s⇩t (transaction_checks T))"
define T4 where "T4 ≡ unlabel (dual⇩l⇩s⇩s⇩t (transaction_updates T))"
define T5 where "T5 ≡ unlabel (dual⇩l⇩s⇩s⇩t (transaction_send T))"
define X where "X ≡ set (transaction_fresh T)"
define Y where "Y ≡ X ∪ wfvarsoccs⇩s⇩s⇩t T1"
define Z where "Z ≡ Y ∪ wfvarsoccs⇩s⇩s⇩t T2"
define f where "f ≡ λS::(('a,'b,'c) prot_fun, ('a,'b,'c) prot_var) stateful_strand.
⋃((λx. case x of
Receive t ⇒ fv t
| Equality Assign _ t' ⇒ fv t'
| Insert t t' ⇒ fv t ∪ fv t'
| _ ⇒ {}) ` set S)"
note defs1 = T1_def T2_def T3_def T4_def T5_def
note defs2 = X_def Y_def Z_def
note defs3 = f_def
have 0: "wf'⇩s⇩s⇩t V (S @ S')"
when "wf'⇩s⇩s⇩t V S" "f S' ⊆ wfvarsoccs⇩s⇩s⇩t S ∪ V" for V S S'
by (metis that wf⇩s⇩s⇩t_append_suffix' f_def)
have 1: "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)) = T1@T2@T3@T4@T5"
using dual⇩l⇩s⇩s⇩t_append unlabel_append unfolding transaction_strand_def defs1 by simp
have 2:
"∀x ∈ set T1. is_Send x" "∀x ∈ set T2. is_Assignment x" "∀x ∈ set T3. is_Check x"
"∀x ∈ set T4. is_Update x" "∀x ∈ set T5. is_Receive x"
"fv⇩s⇩s⇩t T3 ⊆ fv⇩s⇩s⇩t T1 ∪ fv⇩s⇩s⇩t T2" "fv⇩s⇩s⇩t T4 ∪ fv⇩s⇩s⇩t T5 ⊆ X ∪ fv⇩s⇩s⇩t T1 ∪ fv⇩s⇩s⇩t T2"
"X ∩ fv⇩s⇩s⇩t T1 = {}" "X ∩ fv⇩s⇩s⇩t T2 = {}"
"∀x ∈ set T2. is_Equality x ⟶ fv (the_rhs x) ⊆ fv⇩s⇩s⇩t T1"
using T unfolding defs1 defs2 wellformed_transaction_def
by (auto simp add: Ball_set dual⇩l⇩s⇩s⇩t_list_all fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq simp del: fv⇩s⇩s⇩t_def)
have 3: "wf'⇩s⇩s⇩t X T1" using 2(1)
proof (induction T1 arbitrary: X)
case (Cons s T)
obtain t where "s = send⟨t⟩" using Cons.prems by (cases s) moura+
thus ?case using Cons by auto
qed simp
have 4: "f T1 = {}" "fv⇩s⇩s⇩t T1 = wfvarsoccs⇩s⇩s⇩t T1" using 2(1)
proof (induction T1)
case (Cons s T)
{ case 1 thus ?case using Cons unfolding defs3 by (cases s) auto }
{ case 2 thus ?case using Cons unfolding defs3 wfvarsoccs⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def by (cases s) auto }
qed (simp_all add: defs3 wfvarsoccs⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def)
have 5: "f T2 ⊆ wfvarsoccs⇩s⇩s⇩t T1" "fv⇩s⇩s⇩t T2 = f T2 ∪ wfvarsoccs⇩s⇩s⇩t T2" using 2(2,10)
proof (induction T2)
case (Cons s T)
{ case 1 thus ?case using Cons
proof (cases s)
case (Equality ac t t') thus ?thesis using 1 Cons 4(2) unfolding defs3 by (cases ac) auto
qed (simp_all add: defs3)
}
{ case 2 thus ?case using Cons
proof (cases s)
case (Equality ac t t')
hence "ac = Assign" "fv⇩s⇩s⇩t⇩p s = fv t' ∪ wfvarsoccs⇩s⇩s⇩t⇩p s" "f (s#T) = fv t' ∪ f T"
using 2 unfolding defs3 by auto
moreover have "fv⇩s⇩s⇩t T = f T ∪ wfvarsoccs⇩s⇩s⇩t T" using Cons.IH(2) 2 by auto
ultimately show ?thesis unfolding wfvarsoccs⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def by auto
next
case (InSet ac t t')
hence "ac = Assign" "fv⇩s⇩s⇩t⇩p s = wfvarsoccs⇩s⇩s⇩t⇩p s" "f (s#T) = f T"
using 2 unfolding defs3 by auto
moreover have "fv⇩s⇩s⇩t T = f T ∪ wfvarsoccs⇩s⇩s⇩t T" using Cons.IH(2) 2 by auto
ultimately show ?thesis unfolding wfvarsoccs⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def by auto
qed (simp_all add: defs3)
}
qed (simp_all add: defs3 wfvarsoccs⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def)
have "f T ⊆ fv⇩s⇩s⇩t T" for T
proof
fix x show "x ∈ f T ⟹ x ∈ fv⇩s⇩s⇩t T"
proof (induction T)
case (Cons s T) thus ?case
proof (cases "x ∈ f T")
case False thus ?thesis
using Cons.prems unfolding defs3 fv⇩s⇩s⇩t_def
by (auto split: stateful_strand_step.splits poscheckvariant.splits)
qed auto
qed (simp add: defs3 fv⇩s⇩s⇩t_def)
qed
hence 6:
"f T3 ⊆ X ∪ wfvarsoccs⇩s⇩s⇩t T1 ∪ wfvarsoccs⇩s⇩s⇩t T2"
"f T4 ⊆ X ∪ wfvarsoccs⇩s⇩s⇩t T1 ∪ wfvarsoccs⇩s⇩s⇩t T2"
"f T5 ⊆ X ∪ wfvarsoccs⇩s⇩s⇩t T1 ∪ wfvarsoccs⇩s⇩s⇩t T2"
using 2(6,7) 4 5 by blast+
have 7:
"wfvarsoccs⇩s⇩s⇩t T3 = {}"
"wfvarsoccs⇩s⇩s⇩t T4 = {}"
"wfvarsoccs⇩s⇩s⇩t T5 = {}"
using 2(3,4,5) unfolding wfvarsoccs⇩s⇩s⇩t_def
by (auto split: stateful_strand_step.splits)
have 8:
"f T2 ⊆ wfvarsoccs⇩s⇩s⇩t T1 ∪ X"
"f T3 ⊆ wfvarsoccs⇩s⇩s⇩t (T1@T2) ∪ X"
"f T4 ⊆ wfvarsoccs⇩s⇩s⇩t ((T1@T2)@T3) ∪ X"
"f T5 ⊆ wfvarsoccs⇩s⇩s⇩t (((T1@T2)@T3)@T4) ∪ X"
using 4(1) 5(1) 6 7 wfvarsoccs⇩s⇩s⇩t_append[of T1 T2]
wfvarsoccs⇩s⇩s⇩t_append[of "T1@T2" T3]
wfvarsoccs⇩s⇩s⇩t_append[of "(T1@T2)@T3" T4]
by blast+
have "wf'⇩s⇩s⇩t X (T1@T2@T3@T4@T5)"
using 0[OF 0[OF 0[OF 0[OF 3 8(1)] 8(2)] 8(3)] 8(4)]
unfolding Y_def Z_def by simp
thus ?A using 1 unfolding defs1 defs2 by simp
have "set (transaction_fresh T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪ fv⇩l⇩s⇩s⇩t (transaction_send T)"
"fv_transaction T ∩ bvars_transaction T = {}"
using T unfolding wellformed_transaction_def by fast+
thus ?B ?C using fv_transaction_unfold[of T] bvars_transaction_unfold[of T] by blast+
qed
lemma dual_wellformed_transaction_ident_cases'[dest]:
assumes "wellformed_transaction T"
shows "dual⇩l⇩s⇩s⇩t (transaction_selects T) = transaction_selects T"
"dual⇩l⇩s⇩s⇩t (transaction_checks T) = transaction_checks T"
"dual⇩l⇩s⇩s⇩t (transaction_updates T) = transaction_updates T"
using assms unfolding wellformed_transaction_def by auto
lemma dual_transaction_strand:
assumes "wellformed_transaction T"
shows "dual⇩l⇩s⇩s⇩t (transaction_strand T) =
dual⇩l⇩s⇩s⇩t (transaction_receive T)@transaction_selects T@transaction_checks T@
transaction_updates T@dual⇩l⇩s⇩s⇩t (transaction_send T)"
using dual_wellformed_transaction_ident_cases'[OF assms] dual⇩l⇩s⇩s⇩t_append
unfolding transaction_strand_def by metis
lemma dual_unlabel_transaction_strand:
assumes "wellformed_transaction T"
shows "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)) =
(unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T)))@(unlabel (transaction_selects T))@
(unlabel (transaction_checks T))@(unlabel (transaction_updates T))@
(unlabel (dual⇩l⇩s⇩s⇩t (transaction_send T)))"
using dual_transaction_strand[OF assms] by (simp add: unlabel_def)
lemma dual_transaction_strand_subst:
assumes "wellformed_transaction T"
shows "dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ) =
(dual⇩l⇩s⇩s⇩t (transaction_receive T)@transaction_selects T@transaction_checks T@
transaction_updates T@dual⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩l⇩s⇩s⇩t δ"
proof -
have "dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ) = dual⇩l⇩s⇩s⇩t (transaction_strand T) ⋅⇩l⇩s⇩s⇩t δ"
using dual⇩l⇩s⇩s⇩t_subst by metis
thus ?thesis using dual_transaction_strand[OF assms] by argo
qed
lemma dual_transaction_ik_is_transaction_send:
assumes "wellformed_transaction T"
shows "ik⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T))) = trms⇩s⇩s⇩t (unlabel (transaction_send T))"
(is "?A = ?B")
proof -
{ fix t assume "t ∈ ?A"
hence "receive⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)))" by (simp add: ik⇩s⇩s⇩t_def)
hence "send⟨t⟩ ∈ set (unlabel (transaction_strand T))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(1) by metis
hence "t ∈ ?B" using wellformed_transaction_strand_unlabel_memberD(8)[OF assms] by force
} moreover {
fix t assume "t ∈ ?B"
hence "send⟨t⟩ ∈ set (unlabel (transaction_send T))"
using wellformed_transaction_unlabel_cases(5)[OF assms] by fastforce
hence "receive⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_send T)))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(1) by metis
hence "receive⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)))"
using dual_unlabel_transaction_strand[OF assms] by simp
hence "t ∈ ?A" by (simp add: ik⇩s⇩s⇩t_def)
} ultimately show "?A = ?B" by auto
qed
lemma dual_transaction_ik_is_transaction_send':
fixes δ::"('a,'b,'c) prot_subst"
assumes "wellformed_transaction T"
shows "ik⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ))) =
trms⇩s⇩s⇩t (unlabel (transaction_send T)) ⋅⇩s⇩e⇩t δ" (is "?A = ?B")
using dual_transaction_ik_is_transaction_send[OF assms]
subst_lsst_unlabel[of "dual⇩l⇩s⇩s⇩t (transaction_strand T)" δ]
ik⇩s⇩s⇩t_subst[of "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T))" δ]
dual⇩l⇩s⇩s⇩t_subst[of "transaction_strand T" δ]
by auto
lemma db⇩s⇩s⇩t_transaction_prefix_eq:
assumes T: "wellformed_transaction T"
and S: "prefix S (transaction_receive T@transaction_selects T@transaction_checks T)"
shows "db⇩l⇩s⇩s⇩t A = db⇩l⇩s⇩s⇩t (A@dual⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ))"
proof -
let ?T1 = "transaction_receive T"
let ?T2 = "transaction_selects T"
let ?T3 = "transaction_checks T"
have *: "prefix (unlabel S) (unlabel (?T1@?T2@?T3))" using S prefix_proj(1) by blast
have "list_all is_Receive (unlabel ?T1)"
"list_all is_Assignment (unlabel ?T2)"
"list_all is_Check (unlabel ?T3)"
using T by (simp_all add: wellformed_transaction_def)
hence "∀b ∈ set (unlabel ?T1). ¬is_Insert b ∧ ¬is_Delete b"
"∀b ∈ set (unlabel ?T2). ¬is_Insert b ∧ ¬is_Delete b"
"∀b ∈ set (unlabel ?T3). ¬is_Insert b ∧ ¬is_Delete b"
by (metis (mono_tags, lifting) Ball_set stateful_strand_step.distinct_disc(16,18),
metis (mono_tags, lifting) Ball_set stateful_strand_step.distinct_disc(24,26,33,37),
metis (mono_tags, lifting) Ball_set stateful_strand_step.distinct_disc(24,26,33,35,37,39))
hence "∀b ∈ set (unlabel (?T1@?T2@?T3)). ¬is_Insert b ∧ ¬is_Delete b"
by (auto simp add: unlabel_def)
hence "∀b ∈ set (unlabel S). ¬is_Insert b ∧ ¬is_Delete b"
using * unfolding prefix_def by fastforce
hence "∀b ∈ set (unlabel (dual⇩l⇩s⇩s⇩t S) ⋅⇩s⇩s⇩t δ). ¬is_Insert b ∧ ¬is_Delete b"
proof (induction S)
case (Cons a S)
then obtain l b where "a = (l,b)" by (metis surj_pair)
thus ?case
using Cons unfolding dual⇩l⇩s⇩s⇩t_def unlabel_def subst_apply_stateful_strand_def
by (cases b) auto
qed simp
hence **: "∀b ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ))). ¬is_Insert b ∧ ¬is_Delete b"
by (metis dual⇩l⇩s⇩s⇩t_subst_unlabel)
show ?thesis
using db⇩s⇩s⇩t_no_upd_append[OF **] unlabel_append
unfolding db⇩s⇩s⇩t_def by metis
qed
lemma db⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t_set_ex:
assumes "d ∈ set (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D)"
"∀t u. insert⟨t,u⟩ ∈ set (unlabel A) ⟶ (∃s. u = Fun (Set s) [])"
"∀t u. delete⟨t,u⟩ ∈ set (unlabel A) ⟶ (∃s. u = Fun (Set s) [])"
"∀d ∈ set D. ∃s. snd d = Fun (Set s) []"
shows "∃s. snd d = Fun (Set s) []"
using assms
proof (induction A arbitrary: D)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
have 1: "unlabel (dual⇩l⇩s⇩s⇩t (a#A) ⋅⇩l⇩s⇩s⇩t θ) = receive⟨t ⋅ θ⟩#unlabel (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ)"
when "b = send⟨t⟩" for t
by (simp add: a that subst_lsst_unlabel_cons)
have 2: "unlabel (dual⇩l⇩s⇩s⇩t (a#A) ⋅⇩l⇩s⇩s⇩t θ) = send⟨t ⋅ θ⟩#unlabel (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ)"
when "b = receive⟨t⟩" for t
by (simp add: a that subst_lsst_unlabel_cons)
have 3: "unlabel (dual⇩l⇩s⇩s⇩t (a#A) ⋅⇩l⇩s⇩s⇩t θ) = (b ⋅⇩s⇩s⇩t⇩p θ)#unlabel (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ)"
when "∄t. b = send⟨t⟩ ∨ b = receive⟨t⟩"
using a that dual⇩l⇩s⇩s⇩t_Cons subst_lsst_unlabel_cons[of l b]
by (cases b) auto
show ?case using 1 2 3 a Cons by (cases b) fastforce+
qed simp
lemma is_Fun_SetE[elim]:
assumes t: "is_Fun_Set t"
obtains s where "t = Fun (Set s) []"
proof (cases t)
case (Fun f T)
then obtain s where "f = Set s" using t unfolding is_Fun_Set_def by (cases f) moura+
moreover have "T = []" using Fun t unfolding is_Fun_Set_def by (cases T) auto
ultimately show ?thesis using Fun that by fast
qed (use t is_Fun_Set_def in fast)
lemma Fun_Set_InSet_iff:
"(u = ⟨a: Var x ∈ Fun (Set s) []⟩) ⟷
(is_InSet u ∧ is_Var (the_elem_term u) ∧ is_Fun_Set (the_set_term u) ∧
the_Set (the_Fun (the_set_term u)) = s ∧ the_Var (the_elem_term u) = x ∧ the_check u = a)"
(is "?A ⟷ ?B")
proof
show "?A ⟹ ?B" unfolding is_Fun_Set_def by auto
assume B: ?B
thus ?A
proof (cases u)
case (InSet b t t')
hence "b = a" "t = Var x" "t' = Fun (Set s) []"
using B by (simp, fastforce, fastforce)
thus ?thesis using InSet by fast
qed auto
qed
lemma Fun_Set_NotInSet_iff:
"(u = ⟨Var x not in Fun (Set s) []⟩) ⟷
(is_NegChecks u ∧ bvars⇩s⇩s⇩t⇩p u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1 ∧
is_Var (fst (hd (the_ins u))) ∧ is_Fun_Set (snd (hd (the_ins u)))) ∧
the_Set (the_Fun (snd (hd (the_ins u)))) = s ∧ the_Var (fst (hd (the_ins u))) = x"
(is "?A ⟷ ?B")
proof
show "?A ⟹ ?B" unfolding is_Fun_Set_def by auto
assume B: ?B
show ?A
proof (cases u)
case (NegChecks X F F')
hence "X = []" "F = []"
using B by auto
moreover have "fst (hd (the_ins u)) = Var x" "snd (hd (the_ins u)) = Fun (Set s) []"
using B is_Fun_SetE[of "snd (hd (the_ins u))"]
by (force, fastforce)
hence "F' = [(Var x, Fun (Set s) [])]"
using NegChecks B by (cases "the_ins u") auto
ultimately show ?thesis using NegChecks by fast
qed (use B in auto)
qed
lemma is_Fun_Set_exi: "is_Fun_Set x ⟷ (∃s. x = Fun (Set s) [])"
by (metis prot_fun.collapse(2) term.collapse(2) prot_fun.disc(15) term.disc(2)
term.sel(2,4) is_Fun_Set_def un_Fun1_def)
lemma is_Fun_Set_subst:
assumes "is_Fun_Set S'"
shows "is_Fun_Set (S' ⋅ σ)"
using assms by (fastforce simp add: is_Fun_Set_def)
lemma is_Update_in_transaction_updates:
assumes tu: "is_Update t"
assumes t: "t ∈ set (unlabel (transaction_strand TT))"
assumes vt: "wellformed_transaction TT"
shows "t ∈ set (unlabel (transaction_updates TT))"
using t tu vt unfolding transaction_strand_def wellformed_transaction_def list_all_iff
by (auto simp add: unlabel_append)
lemma transaction_fresh_vars_subset:
assumes "wellformed_transaction T"
shows "set (transaction_fresh T) ⊆ fv_transaction T"
using assms fv_transaction_unfold[of T]
unfolding wellformed_transaction_def
by auto
lemma transaction_fresh_vars_notin:
assumes T: "wellformed_transaction T"
and x: "x ∈ set (transaction_fresh T)"
shows "x ∉ fv⇩l⇩s⇩s⇩t (transaction_receive T)" (is ?A)
and "x ∉ fv⇩l⇩s⇩s⇩t (transaction_selects T)" (is ?B)
and "x ∉ fv⇩l⇩s⇩s⇩t (transaction_checks T)" (is ?C)
and "x ∉ vars⇩l⇩s⇩s⇩t (transaction_receive T)" (is ?D)
and "x ∉ vars⇩l⇩s⇩s⇩t (transaction_selects T)" (is ?E)
and "x ∉ vars⇩l⇩s⇩s⇩t (transaction_checks T)" (is ?F)
and "x ∉ bvars⇩l⇩s⇩s⇩t (transaction_receive T)" (is ?G)
and "x ∉ bvars⇩l⇩s⇩s⇩t (transaction_selects T)" (is ?H)
and "x ∉ bvars⇩l⇩s⇩s⇩t (transaction_checks T)" (is ?I)
proof -
have 0:
"set (transaction_fresh T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪ fv⇩l⇩s⇩s⇩t (transaction_send T)"
"set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_receive T) = {}"
"set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_selects T) = {}"
"fv_transaction T ∩ bvars_transaction T = {}"
"fv⇩l⇩s⇩s⇩t (transaction_checks T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using T unfolding wellformed_transaction_def
by fast+
have 1: "set (transaction_fresh T) ∩ bvars⇩l⇩s⇩s⇩t (transaction_checks T) = {}"
using 0(1,4) fv_transaction_unfold[of T] bvars_transaction_unfold[of T] by blast
have 2:
"vars⇩l⇩s⇩s⇩t (transaction_receive T) = fv⇩l⇩s⇩s⇩t (transaction_receive T)"
"vars⇩l⇩s⇩s⇩t (transaction_selects T) = fv⇩l⇩s⇩s⇩t (transaction_selects T)"
"bvars⇩l⇩s⇩s⇩t (transaction_receive T) = {}"
"bvars⇩l⇩s⇩s⇩t (transaction_selects T) = {}"
using bvars_wellformed_transaction_unfold[OF T] bvars_transaction_unfold[of T]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_receive T)"]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_selects T)"]
by blast+
show ?A ?B ?C ?D ?E ?G ?H ?I using 0 1 2 x by fast+
show ?F using 0(2,3,5) 1 x vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_checks T)"] by fast
qed
lemma transaction_proj_member:
assumes "T ∈ set P"
shows "transaction_proj n T ∈ set (map (transaction_proj n) P)"
using assms by simp
lemma transaction_strand_proj:
"transaction_strand (transaction_proj n T) = proj n (transaction_strand T)"
proof -
obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
thus ?thesis
using transaction_proj.simps[of n A B C D E F]
unfolding transaction_strand_def proj_def Let_def by auto
qed
lemma transaction_proj_fresh_eq:
"transaction_fresh (transaction_proj n T) = transaction_fresh T"
proof -
obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
thus ?thesis
using transaction_proj.simps[of n A B C D E F]
unfolding transaction_fresh_def proj_def Let_def by auto
qed
lemma transaction_proj_trms_subset:
"trms_transaction (transaction_proj n T) ⊆ trms_transaction T"
proof -
obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
thus ?thesis
using transaction_proj.simps[of n A B C D E F] trms⇩s⇩s⇩t_proj_subset(1)[of n]
unfolding transaction_fresh_def Let_def transaction_strand_def by auto
qed
lemma transaction_proj_vars_subset:
"vars_transaction (transaction_proj n T) ⊆ vars_transaction T"
proof -
obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
thus ?thesis
using transaction_proj.simps[of n A B C D E F]
sst_vars_proj_subset(3)[of n "transaction_strand T"]
unfolding transaction_fresh_def Let_def transaction_strand_def by simp
qed
end
Theory Term_Abstraction
section‹Term Abstraction›
theory Term_Abstraction
imports Transactions
begin
subsection ‹Definitions›
fun to_abs ("α⇩0") where
"α⇩0 [] _ = {}"
| "α⇩0 ((Fun (Val m) [],Fun (Set s) S)#D) n =
(if m = n then insert s (α⇩0 D n) else α⇩0 D n)"
| "α⇩0 (_#D) n = α⇩0 D n"
fun abs_apply_term (infixl "⋅⇩α" 67) where
"Var x ⋅⇩α α = Var x"
| "Fun (Val n) T ⋅⇩α α = Fun (Abs (α n)) (map (λt. t ⋅⇩α α) T)"
| "Fun f T ⋅⇩α α = Fun f (map (λt. t ⋅⇩α α) T)"
definition abs_apply_list (infixl "⋅⇩α⇩l⇩i⇩s⇩t" 67) where
"M ⋅⇩α⇩l⇩i⇩s⇩t α ≡ map (λt. t ⋅⇩α α) M"
definition abs_apply_terms (infixl "⋅⇩α⇩s⇩e⇩t" 67) where
"M ⋅⇩α⇩s⇩e⇩t α ≡ (λt. t ⋅⇩α α) ` M"
definition abs_apply_pairs (infixl "⋅⇩α⇩p⇩a⇩i⇩r⇩s" 67) where
"F ⋅⇩α⇩p⇩a⇩i⇩r⇩s α ≡ map (λ(s,t). (s ⋅⇩α α, t ⋅⇩α α)) F"
definition abs_apply_strand_step (infixl "⋅⇩α⇩s⇩t⇩p" 67) where
"s ⋅⇩α⇩s⇩t⇩p α ≡ (case s of
(l,send⟨t⟩) ⇒ (l,send⟨t ⋅⇩α α⟩)
| (l,receive⟨t⟩) ⇒ (l,receive⟨t ⋅⇩α α⟩)
| (l,⟨ac: t ≐ t'⟩) ⇒ (l,⟨ac: (t ⋅⇩α α) ≐ (t' ⋅⇩α α)⟩)
| (l,insert⟨t,t'⟩) ⇒ (l,insert⟨t ⋅⇩α α,t' ⋅⇩α α⟩)
| (l,delete⟨t,t'⟩) ⇒ (l,delete⟨t ⋅⇩α α,t' ⋅⇩α α⟩)
| (l,⟨ac: t ∈ t'⟩) ⇒ (l,⟨ac: (t ⋅⇩α α) ∈ (t' ⋅⇩α α)⟩)
| (l,∀X⟨∨≠: F ∨∉: F'⟩) ⇒ (l,∀X⟨∨≠: (F ⋅⇩α⇩p⇩a⇩i⇩r⇩s α) ∨∉: (F' ⋅⇩α⇩p⇩a⇩i⇩r⇩s α)⟩))"
definition abs_apply_strand (infixl "⋅⇩α⇩s⇩t" 67) where
"S ⋅⇩α⇩s⇩t α ≡ map (λx. x ⋅⇩α⇩s⇩t⇩p α) S"
subsection ‹Lemmata›
lemma to_abs_alt_def:
"α⇩0 D n = {s. ∃S. (Fun (Val n) [], Fun (Set s) S) ∈ set D}"
by (induct D n rule: to_abs.induct) auto
lemma abs_term_apply_const[simp]:
"is_Val f ⟹ Fun f [] ⋅⇩α a = Fun (Abs (a (the_Val f))) []"
"¬is_Val f ⟹ Fun f [] ⋅⇩α a = Fun f []"
by (cases f; auto)+
lemma abs_fv: "fv (t ⋅⇩α a) = fv t"
by (induct t a rule: abs_apply_term.induct) auto
lemma abs_eq_if_no_Val:
assumes "∀f ∈ funs_term t. ¬is_Val f"
shows "t ⋅⇩α a = t ⋅⇩α b"
using assms
proof (induction t)
case (Fun f T) thus ?case by (cases f) simp_all
qed simp
lemma abs_list_set_is_set_abs_set: "set (M ⋅⇩α⇩l⇩i⇩s⇩t α) = (set M) ⋅⇩α⇩s⇩e⇩t α"
unfolding abs_apply_list_def abs_apply_terms_def by simp
lemma abs_set_empty[simp]: "{} ⋅⇩α⇩s⇩e⇩t α = {}"
unfolding abs_apply_terms_def by simp
lemma abs_in:
assumes "t ∈ M"
shows "t ⋅⇩α α ∈ M ⋅⇩α⇩s⇩e⇩t α"
using assms unfolding abs_apply_terms_def
by (induct t α rule: abs_apply_term.induct) blast+
lemma abs_set_union: "(A ∪ B) ⋅⇩α⇩s⇩e⇩t a = (A ⋅⇩α⇩s⇩e⇩t a) ∪ (B ⋅⇩α⇩s⇩e⇩t a)"
unfolding abs_apply_terms_def
by auto
lemma abs_subterms: "subterms (t ⋅⇩α α) = subterms t ⋅⇩α⇩s⇩e⇩t α"
proof (induction t)
case (Fun f T) thus ?case by (cases f) (auto simp add: abs_apply_terms_def)
qed (simp add: abs_apply_terms_def)
lemma abs_subterms_in: "s ∈ subterms t ⟹ s ⋅⇩α a ∈ subterms (t ⋅⇩α a)"
proof (induction t)
case (Fun f T) thus ?case by (cases f) auto
qed simp
lemma abs_ik_append: "(ik⇩s⇩s⇩t (A@B) ⋅⇩s⇩e⇩t I) ⋅⇩α⇩s⇩e⇩t a = (ik⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I) ⋅⇩α⇩s⇩e⇩t a ∪ (ik⇩s⇩s⇩t B ⋅⇩s⇩e⇩t I) ⋅⇩α⇩s⇩e⇩t a"
unfolding abs_apply_terms_def ik⇩s⇩s⇩t_def
by auto
lemma to_abs_in:
assumes "(Fun (Val n) [], Fun (Set s) []) ∈ set D"
shows "s ∈ α⇩0 D n"
using assms by (induct rule: to_abs.induct) auto
lemma to_abs_empty_iff_notin_db:
"Fun (Val n) [] ⋅⇩α α⇩0 D = Fun (Abs {}) [] ⟷ (∄s S. (Fun (Val n) [], Fun (Set s) S) ∈ set D)"
by (simp add: to_abs_alt_def)
lemma to_abs_list_insert:
assumes "Fun (Val n) [] ≠ t"
shows "α⇩0 D n = α⇩0 (List.insert (t,s) D) n"
using assms to_abs_alt_def[of D n] to_abs_alt_def[of "List.insert (t,s) D" n]
by auto
lemma to_abs_list_insert':
"insert s (α⇩0 D n) = α⇩0 (List.insert (Fun (Val n) [], Fun (Set s) S) D) n"
using to_abs_alt_def[of D n]
to_abs_alt_def[of "List.insert (Fun (Val n) [], Fun (Set s) S) D" n]
by auto
lemma to_abs_list_remove_all:
assumes "Fun (Val n) [] ≠ t"
shows "α⇩0 D n = α⇩0 (List.removeAll (t,s) D) n"
using assms to_abs_alt_def[of D n] to_abs_alt_def[of "List.removeAll (t,s) D" n]
by auto
lemma to_abs_list_remove_all':
"α⇩0 D n - {s} = α⇩0 (filter (λd. ∄S. d = (Fun (Val n) [], Fun (Set s) S)) D) n"
using to_abs_alt_def[of D n]
to_abs_alt_def[of "filter (λd. ∄S. d = (Fun (Val n) [], Fun (Set s) S)) D" n]
by auto
lemma to_abs_db⇩s⇩s⇩t_append:
assumes "∀u s. insert⟨u, s⟩ ∈ set B ⟶ Fun (Val n) [] ≠ u ⋅ ℐ"
and "∀u s. delete⟨u, s⟩ ∈ set B ⟶ Fun (Val n) [] ≠ u ⋅ ℐ"
shows "α⇩0 (db'⇩s⇩s⇩t A ℐ D) n = α⇩0 (db'⇩s⇩s⇩t (A@B) ℐ D) n"
using assms
proof (induction B rule: List.rev_induct)
case (snoc b B)
hence IH: "α⇩0 (db'⇩s⇩s⇩t A ℐ D) n = α⇩0 (db'⇩s⇩s⇩t (A@B) ℐ D) n" by auto
have *: "∀u s. b = insert⟨u,s⟩ ⟶ Fun (Val n) [] ≠ u ⋅ ℐ"
"∀u s. b = delete⟨u,s⟩ ⟶ Fun (Val n) [] ≠ u ⋅ ℐ"
using snoc.prems by simp_all
show ?case
proof (cases b)
case (Insert u s)
hence **: "db'⇩s⇩s⇩t (A@B@[b]) ℐ D = List.insert (u ⋅ ℐ,s ⋅ ℐ) (db'⇩s⇩s⇩t (A@B) ℐ D)"
using db⇩s⇩s⇩t_append[of "A@B" "[b]"] by simp
have "Fun (Val n) [] ≠ u ⋅ ℐ" using *(1) Insert by auto
thus ?thesis using IH ** to_abs_list_insert by metis
next
case (Delete u s)
hence **: "db'⇩s⇩s⇩t (A@B@[b]) ℐ D = List.removeAll (u ⋅ ℐ,s ⋅ ℐ) (db'⇩s⇩s⇩t (A@B) ℐ D)"
using db⇩s⇩s⇩t_append[of "A@B" "[b]"] by simp
have "Fun (Val n) [] ≠ u ⋅ ℐ" using *(2) Delete by auto
thus ?thesis using IH ** to_abs_list_remove_all by metis
qed (simp_all add: db⇩s⇩s⇩t_no_upd_append[of "[b]" "A@B"] IH)
qed simp
lemma to_abs_neq_imp_db_update:
assumes "α⇩0 (db⇩s⇩s⇩t A I) n ≠ α⇩0 (db⇩s⇩s⇩t (A@B) I) n"
shows "∃u s. u ⋅ I = Fun (Val n) [] ∧ (insert⟨u,s⟩ ∈ set B ∨ delete⟨u,s⟩ ∈ set B)"
proof -
{ fix D have ?thesis when "α⇩0 D n ≠ α⇩0 (db'⇩s⇩s⇩t B I D) n" using that
proof (induction B I D rule: db'⇩s⇩s⇩t.induct)
case 2 thus ?case
by (metis db'⇩s⇩s⇩t.simps(2) list.set_intros(1,2) subst_apply_pair_pair to_abs_list_insert)
next
case 3 thus ?case
by (metis db'⇩s⇩s⇩t.simps(3) list.set_intros(1,2) subst_apply_pair_pair to_abs_list_remove_all)
qed simp_all
} thus ?thesis using assms by (metis db⇩s⇩s⇩t_append db⇩s⇩s⇩t_def)
qed
lemma abs_term_subst_eq:
fixes δ θ::"(('a,'b,'c) prot_fun, ('d,'e prot_atom) term × nat) subst"
assumes "∀x ∈ fv t. δ x ⋅⇩α a = θ x ⋅⇩α b"
and "∄n T. Fun (Val n) T ∈ subterms t"
shows "t ⋅ δ ⋅⇩α a = t ⋅ θ ⋅⇩α b"
using assms
proof (induction t)
case (Fun f T) thus ?case
proof (cases f)
case (Val n)
hence False using Fun.prems(2) by blast
thus ?thesis by metis
qed auto
qed simp
lemma abs_term_subst_eq':
fixes δ θ::"(('a,'b,'c) prot_fun, ('d,'e prot_atom) term × nat) subst"
assumes "∀x ∈ fv t. δ x ⋅⇩α a = θ x"
and "∄n T. Fun (Val n) T ∈ subterms t"
shows "t ⋅ δ ⋅⇩α a = t ⋅ θ"
using assms
proof (induction t)
case (Fun f T) thus ?case
proof (cases f)
case (Val n)
hence False using Fun.prems(2) by blast
thus ?thesis by metis
qed auto
qed simp
lemma abs_val_in_funs_term:
assumes "f ∈ funs_term t" "is_Val f"
shows "Abs (α (the_Val f)) ∈ funs_term (t ⋅⇩α α)"
using assms by (induct t α rule: abs_apply_term.induct) auto
end
Theory Stateful_Protocol_Model
section‹Stateful Protocol Model›
theory Stateful_Protocol_Model
imports Stateful_Protocol_Composition_and_Typing.Stateful_Compositionality
Transactions Term_Abstraction
begin
subsection ‹Locale Setup›
locale stateful_protocol_model =
fixes arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
assumes Ana⇩f_assm1: "∀f. let (K, M) = Ana⇩f f in (∀k ∈ subterms⇩s⇩e⇩t (set K).
is_Fun k ⟶ (is_Fu (the_Fun k)) ∧ length (args k) = arity⇩f (the_Fu (the_Fun k)))"
and Ana⇩f_assm2: "∀f. let (K, M) = Ana⇩f f in ∀i ∈ fv⇩s⇩e⇩t (set K) ∪ set M. i < arity⇩f f"
and public⇩f_assm: "∀f. arity⇩f f > (0::nat) ⟶ public⇩f f"
and Γ⇩f_assm: "∀f. arity⇩f f = (0::nat) ⟶ Γ⇩f f ≠ None"
and label_witness_assm: "label_witness1 ≠ label_witness2"
begin
lemma Ana⇩f_assm1_alt:
assumes "Ana⇩f f = (K,M)" "k ∈ subterms⇩s⇩e⇩t (set K)"
shows "(∃x. k = Var x) ∨ (∃h T. k = Fun (Fu h) T ∧ length T = arity⇩f h)"
proof (cases k)
case (Fun g T)
let ?P = "λk. is_Fun k ⟶ is_Fu (the_Fun k) ∧ length (args k) = arity⇩f (the_Fu (the_Fun k))"
let ?Q = "λK M. ∀k ∈ subterms⇩s⇩e⇩t (set K). ?P k"
have "?Q (fst (Ana⇩f f)) (snd (Ana⇩f f))" using Ana⇩f_assm1 split_beta[of ?Q "Ana⇩f f"] by meson
hence "?Q K M" using assms(1) by simp
hence "?P k" using assms(2) by blast
thus ?thesis using Fun by (cases g) auto
qed simp
lemma Ana⇩f_assm2_alt:
assumes "Ana⇩f f = (K,M)" "i ∈ fv⇩s⇩e⇩t (set K) ∪ set M"
shows "i < arity⇩f f"
using Ana⇩f_assm2 assms by fastforce
subsection ‹Definitions›
fun arity where
"arity (Fu f) = arity⇩f f"
| "arity (Set s) = arity⇩s s"
| "arity (Val _) = 0"
| "arity (Abs _) = 0"
| "arity Pair = 2"
| "arity (Attack _) = 0"
| "arity OccursFact = 2"
| "arity OccursSec = 0"
| "arity (PubConstAtom _ _) = 0"
| "arity (PubConstSetType _) = 0"
| "arity (PubConstAttackType _) = 0"
| "arity (PubConstBottom _) = 0"
| "arity (PubConstOccursSecType _) = 0"
fun public where
"public (Fu f) = public⇩f f"
| "public (Set s) = (arity⇩s s > 0)"
| "public (Val n) = snd n"
| "public (Abs _) = False"
| "public Pair = True"
| "public (Attack _) = False"
| "public OccursFact = True"
| "public OccursSec = False"
| "public (PubConstAtom _ _) = True"
| "public (PubConstSetType _) = True"
| "public (PubConstAttackType _) = True"
| "public (PubConstBottom _) = True"
| "public (PubConstOccursSecType _) = True"
fun Ana where
"Ana (Fun (Fu f) T) = (
if arity⇩f f = length T ∧ arity⇩f f > 0
then let (K,M) = Ana⇩f f in (K ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M)
else ([], []))"
| "Ana _ = ([], [])"
definition Γ⇩v where
"Γ⇩v v ≡ (
if (∀t ∈ subterms (fst v).
case t of (TComp f T) ⇒ arity f > 0 ∧ arity f = length T | _ ⇒ True)
then fst v
else TAtom Bottom)"
fun Γ where
"Γ (Var v) = Γ⇩v v"
| "Γ (Fun f T) = (
if arity f = 0
then case f of
(Fu g) ⇒ TAtom (case Γ⇩f g of Some a ⇒ Atom a | None ⇒ Bottom)
| (Val _) ⇒ TAtom Value
| (Abs _) ⇒ TAtom Value
| (Set _) ⇒ TAtom SetType
| (Attack _) ⇒ TAtom AttackType
| OccursSec ⇒ TAtom OccursSecType
| (PubConstAtom a _) ⇒ TAtom (Atom a)
| (PubConstSetType _) ⇒ TAtom SetType
| (PubConstAttackType _) ⇒ TAtom AttackType
| (PubConstBottom _) ⇒ TAtom Bottom
| (PubConstOccursSecType _) ⇒ TAtom OccursSecType
| _ ⇒ TAtom Bottom
else TComp f (map Γ T))"
lemma Γ_consts_simps[simp]:
"arity⇩f g = 0 ⟹ Γ (Fun (Fu g) []) = TAtom (case Γ⇩f g of Some a ⇒ Atom a | None ⇒ Bottom)"
"Γ (Fun (Val n) []) = TAtom Value"
"Γ (Fun (Abs b) []) = TAtom Value"
"arity⇩s s = 0 ⟹ Γ (Fun (Set s) []) = TAtom SetType"
"Γ (Fun (Attack x) []) = TAtom AttackType"
"Γ (Fun OccursSec []) = TAtom OccursSecType"
"Γ (Fun (PubConstAtom a t) []) = TAtom (Atom a)"
"Γ (Fun (PubConstSetType t) []) = TAtom SetType"
"Γ (Fun (PubConstAttackType t) []) = TAtom AttackType"
"Γ (Fun (PubConstBottom t) []) = TAtom Bottom"
"Γ (Fun (PubConstOccursSecType t) []) = TAtom OccursSecType"
by simp+
lemma Γ_Set_simps[simp]:
"arity⇩s s ≠ 0 ⟹ Γ (Fun (Set s) T) = TComp (Set s) (map Γ T)"
"Γ (Fun (Set s) T) = TAtom SetType ∨ Γ (Fun (Set s) T) = TComp (Set s) (map Γ T)"
"Γ (Fun (Set s) T) ≠ TAtom Value"
"Γ (Fun (Set s) T) ≠ TAtom (Atom a)"
"Γ (Fun (Set s) T) ≠ TAtom AttackType"
"Γ (Fun (Set s) T) ≠ TAtom OccursSecType"
"Γ (Fun (Set s) T) ≠ TAtom Bottom"
by auto
subsection ‹Locale Interpretations›
lemma Ana_Fu_cases:
assumes "Ana (Fun f T) = (K,M)"
and "f = Fu g"
and "Ana⇩f g = (K',M')"
shows "(K,M) = (if arity⇩f g = length T ∧ arity⇩f g > 0
then (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M')
else ([],[]))" (is ?A)
and "(K,M) = (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M') ∨ (K,M) = ([],[])" (is ?B)
proof -
show ?A using assms by (cases "arity⇩f g = length T ∧ arity⇩f g > 0") auto
thus ?B by metis
qed
lemma Ana_Fu_intro:
assumes "arity⇩f f = length T" "arity⇩f f > 0"
and "Ana⇩f f = (K',M')"
shows "Ana (Fun (Fu f) T) = (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M')"
using assms by simp
lemma Ana_Fu_elim:
assumes "Ana (Fun f T) = (K,M)"
and "f = Fu g"
and "Ana⇩f g = (K',M')"
and "(K,M) ≠ ([],[])"
shows "arity⇩f g = length T" (is ?A)
and "(K,M) = (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M')" (is ?B)
proof -
show ?A using assms by force
moreover have "arity⇩f g > 0" using assms by force
ultimately show ?B using assms by auto
qed
lemma Ana_nonempty_inv:
assumes "Ana t ≠ ([],[])"
shows "∃f T. t = Fun (Fu f) T ∧ arity⇩f f = length T ∧ arity⇩f f > 0 ∧
(∃K M. Ana⇩f f = (K, M) ∧ Ana t = (K ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M))"
using assms
proof (induction t rule: Ana.induct)
case (1 f T)
hence *: "arity⇩f f = length T" "0 < arity⇩f f"
"Ana (Fun (Fu f) T) = (case Ana⇩f f of (K, M) ⇒ (K ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M))"
using Ana.simps(1)[of f T] unfolding Let_def by metis+
obtain K M where **: "Ana⇩f f = (K, M)" by (metis surj_pair)
hence "Ana (Fun (Fu f) T) = (K ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M)" using *(3) by simp
thus ?case using ** *(1,2) by blast
qed simp_all
lemma assm1:
assumes "Ana t = (K,M)"
shows "fv⇩s⇩e⇩t (set K) ⊆ fv t"
using assms
proof (induction t rule: term.induct)
case (Fun f T)
have aux: "fv⇩s⇩e⇩t (set K ⋅⇩s⇩e⇩t (!) T) ⊆ fv⇩s⇩e⇩t (set T)"
when K: "∀i ∈ fv⇩s⇩e⇩t (set K). i < length T"
for K::"(('fun,'atom,'sets) prot_fun, nat) term list"
proof
fix x assume "x ∈ fv⇩s⇩e⇩t (set K ⋅⇩s⇩e⇩t (!) T)"
then obtain k where k: "k ∈ set K" "x ∈ fv (k ⋅ (!) T)" by moura
have "∀i ∈ fv k. i < length T" using K k(1) by simp
thus "x ∈ fv⇩s⇩e⇩t (set T)"
by (metis (no_types, lifting) k(2) contra_subsetD fv_set_mono image_subsetI nth_mem
subst_apply_fv_unfold)
qed
{ fix g assume f: "f = Fu g" and K: "K ≠ []"
obtain K' M' where *: "Ana⇩f g = (K',M')" by moura
have "(K, M) ≠ ([], [])" using K by simp
hence "(K, M) = (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M')" "arity⇩f g = length T"
using Ana_Fu_cases(1)[OF Fun.prems f *]
by presburger+
hence ?case using aux[of K'] Ana⇩f_assm2_alt[OF *] by auto
} thus ?case using Fun by (cases f) fastforce+
qed simp
lemma assm2:
assumes "Ana t = (K,M)"
and "⋀g S'. Fun g S' ⊑ t ⟹ length S' = arity g"
and "k ∈ set K"
and "Fun f T' ⊑ k"
shows "length T' = arity f"
using assms
proof (induction t rule: term.induct)
case (Fun g T)
obtain h where 2: "g = Fu h"
using Fun.prems(1,3) by (cases g) auto
obtain K' M' where 1: "Ana⇩f h = (K',M')" by moura
have "(K,M) ≠ ([],[])" using Fun.prems(3) by auto
hence "(K,M) = (K' ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) M')"
"⋀i. i ∈ fv⇩s⇩e⇩t (set K') ∪ set M' ⟹ i < length T"
using Ana_Fu_cases(1)[OF Fun.prems(1) 2 1] Ana⇩f_assm2_alt[OF 1]
by presburger+
hence "K = K' ⋅⇩l⇩i⇩s⇩t (!) T" and 3: "∀i∈fv⇩s⇩e⇩t (set K'). i < length T" by simp_all
then obtain k' where k': "k' ∈ set K'" "k = k' ⋅ (!) T" using Fun.prems(3) by moura
hence 4: "Fun f T' ∈ subterms (k' ⋅ (!) T)" "fv k' ⊆ fv⇩s⇩e⇩t (set K')"
using Fun.prems(4) by auto
show ?case
proof (cases "∃i ∈ fv k'. Fun f T' ∈ subterms (T ! i)")
case True
hence "Fun f T' ∈ subterms⇩s⇩e⇩t (set T)" using k' Fun.prems(4) 3 by auto
thus ?thesis using Fun.prems(2) by auto
next
case False
then obtain S where "Fun f S ∈ subterms k'" "Fun f T' = Fun f S ⋅ (!) T"
using k'(2) Fun.prems(4) subterm_subst_not_img_subterm by force
thus ?thesis using Ana⇩f_assm1_alt[OF 1, of "Fun f S"] k'(1) by (cases f) auto
qed
qed simp
lemma assm4:
assumes "Ana (Fun f T) = (K, M)"
shows "set M ⊆ set T"
using assms
proof (cases f)
case (Fu g)
obtain K' M' where *: "Ana⇩f g = (K',M')" by moura
have "M = [] ∨ (arity⇩f g = length T ∧ M = map ((!) T) M')"
using Ana_Fu_cases(1)[OF assms Fu *]
by (meson prod.inject)
thus ?thesis using Ana⇩f_assm2_alt[OF *] by auto
qed auto
lemma assm5: "Ana t = (K,M) ⟹ K ≠ [] ∨ M ≠ [] ⟹ Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ)"
proof (induction t rule: term.induct)
case (Fun f T) thus ?case
proof (cases f)
case (Fu g)
obtain K' M' where *: "Ana⇩f g = (K',M')" by moura
have **: "K = K' ⋅⇩l⇩i⇩s⇩t (!) T" "M = map ((!) T) M'"
"arity⇩f g = length T" "∀i ∈ fv⇩s⇩e⇩t (set K') ∪ set M'. i < arity⇩f g" "0 < arity⇩f g"
using Fun.prems(2) Ana_Fu_cases(1)[OF Fun.prems(1) Fu *] Ana⇩f_assm2_alt[OF *]
by (meson prod.inject)+
have ***: "∀i ∈ fv⇩s⇩e⇩t (set K'). i < length T" "∀i ∈ set M'. i < length T" using **(3,4) by auto
have "K ⋅⇩l⇩i⇩s⇩t δ = K' ⋅⇩l⇩i⇩s⇩t (!) (map (λt. t ⋅ δ) T)"
"M ⋅⇩l⇩i⇩s⇩t δ = map ((!) (map (λt. t ⋅ δ) T)) M'"
using subst_idx_map[OF ***(2), of δ]
subst_idx_map'[OF ***(1), of δ]
**(1,2)
by fast+
thus ?thesis using Fu * **(3,5) by auto
qed auto
qed simp
sublocale intruder_model arity public Ana
apply unfold_locales
by (metis assm1, metis assm2, rule Ana.simps, metis assm4, metis assm5)
adhoc_overloading INTRUDER_SYNTH intruder_synth
adhoc_overloading INTRUDER_DEDUCT intruder_deduct
lemma assm6: "arity c = 0 ⟹ ∃a. ∀X. Γ (Fun c X) = TAtom a" by (cases c) auto
lemma assm7: "0 < arity f ⟹ Γ (Fun f T) = TComp f (map Γ T)" by auto
lemma assm8: "infinite {c. Γ (Fun c []::('fun,'atom,'sets) prot_term) = TAtom a ∧ public c}"
(is "?P a")
proof -
let ?T = "λf. (range f)::('fun,'atom,'sets) prot_fun set"
let ?A = "λf. ∀x::nat ∈ UNIV. ∀y::nat ∈ UNIV. (f x = f y) = (x = y)"
let ?B = "λf. ∀x::nat ∈ UNIV. f x ∈ ?T f"
let ?C = "λf. ∀y::('fun,'atom,'sets) prot_fun ∈ ?T f. ∃x ∈ UNIV. y = f x"
let ?D = "λf b. ?T f ⊆ {c. Γ (Fun c []::('fun,'atom,'sets) prot_term) = TAtom b ∧ public c}"
have sub_lmm: "?P b" when "?A f" "?C f" "?C f" "?D f b" for b f
proof -
have "∃g::nat ⇒ ('fun,'atom,'sets) prot_fun. bij_betw g UNIV (?T f)"
using bij_betwI'[of UNIV f "?T f"] that(1,2,3) by blast
hence "infinite (?T f)" by (metis nat_not_finite bij_betw_finite)
thus ?thesis using infinite_super[OF that(4)] by blast
qed
show ?thesis
proof (cases a)
case (Atom b) thus ?thesis using sub_lmm[of "PubConstAtom b" a] by force
next
case Value thus ?thesis using sub_lmm[of "λn. Val (n,True)" a] by force
next
case SetType thus ?thesis using sub_lmm[of PubConstSetType a] by fastforce
next
case AttackType thus ?thesis using sub_lmm[of PubConstAttackType a] by fastforce
next
case Bottom thus ?thesis using sub_lmm[of PubConstBottom a] by fastforce
next
case OccursSecType thus ?thesis using sub_lmm[of PubConstOccursSecType a] by fastforce
qed
qed
lemma assm9: "TComp f T ⊑ Γ t ⟹ arity f > 0"
proof (induction t rule: term.induct)
case (Var x)
hence "Γ (Var x) ≠ TAtom Bottom" by force
hence "∀t ∈ subterms (fst x). case t of
TComp f T ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True"
using Var Γ.simps(1)[of x] unfolding Γ⇩v_def by meson
thus ?case using Var by (fastforce simp add: Γ⇩v_def)
next
case (Fun g S)
have "arity g ≠ 0" using Fun.prems Var_subtermeq assm6 by force
thus ?case using Fun by (cases "TComp f T = TComp g (map Γ S)") auto
qed
lemma assm10: "wf⇩t⇩r⇩m (Γ (Var x))"
unfolding wf⇩t⇩r⇩m_def by (auto simp add: Γ⇩v_def)
lemma assm11: "arity f > 0 ⟹ public f" using public⇩f_assm by (cases f) auto
lemma assm12: "Γ (Var (τ, n)) = Γ (Var (τ, m))" by (simp add: Γ⇩v_def)
lemma assm13: "arity c = 0 ⟹ Ana (Fun c T) = ([],[])" by (cases c) simp_all
lemma assm14:
assumes "Ana (Fun f T) = (K,M)"
shows "Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ)"
proof -
show ?thesis
proof (cases "(K, M) = ([],[])")
case True
{ fix g assume f: "f = Fu g"
obtain K' M' where "Ana⇩f g = (K',M')" by moura
hence ?thesis using assms f True by auto
} thus ?thesis using True assms by (cases f) auto
next
case False
then obtain g where **: "f = Fu g" using assms by (cases f) auto
obtain K' M' where *: "Ana⇩f g = (K',M')" by moura
have ***: "K = K' ⋅⇩l⇩i⇩s⇩t (!) T" "M = map ((!) T) M'" "arity⇩f g = length T"
"∀i ∈ fv⇩s⇩e⇩t (set K') ∪ set M'. i < arity⇩f g"
using Ana_Fu_cases(1)[OF assms ** *] False Ana⇩f_assm2_alt[OF *]
by (meson prod.inject)+
have ****: "∀i∈fv⇩s⇩e⇩t (set K'). i < length T" "∀i∈set M'. i < length T" using ***(3,4) by auto
have "K ⋅⇩l⇩i⇩s⇩t δ = K' ⋅⇩l⇩i⇩s⇩t (!) (map (λt. t ⋅ δ) T)"
"M ⋅⇩l⇩i⇩s⇩t δ = map ((!) (map (λt. t ⋅ δ) T)) M'"
using subst_idx_map[OF ****(2), of δ]
subst_idx_map'[OF ****(1), of δ]
***(1,2)
by auto
thus ?thesis using assms * ** ***(3) by auto
qed
qed
sublocale labeled_stateful_typed_model' arity public Ana Γ Pair label_witness1 label_witness2
by unfold_locales
(metis assm6, metis assm7, metis assm8, metis assm9,
rule assm10, metis assm11, rule arity.simps(5), metis assm14,
metis assm12, metis assm13, metis assm14, rule label_witness_assm)
subsection ‹Minor Lemmata›
lemma Γ⇩v_TAtom[simp]: "Γ⇩v (TAtom a, n) = TAtom a"
unfolding Γ⇩v_def by simp
lemma Γ⇩v_TAtom':
assumes "a ≠ Bottom"
shows "Γ⇩v (τ, n) = TAtom a ⟷ τ = TAtom a"
proof
assume "Γ⇩v (τ, n) = TAtom a"
thus "τ = TAtom a" by (metis (no_types, lifting) assms Γ⇩v_def fst_conv term.inject(1))
qed simp
lemma Γ⇩v_TAtom_inv:
"Γ⇩v x = TAtom (Atom a) ⟹ ∃m. x = (TAtom (Atom a), m)"
"Γ⇩v x = TAtom Value ⟹ ∃m. x = (TAtom Value, m)"
"Γ⇩v x = TAtom SetType ⟹ ∃m. x = (TAtom SetType, m)"
"Γ⇩v x = TAtom AttackType ⟹ ∃m. x = (TAtom AttackType, m)"
"Γ⇩v x = TAtom OccursSecType ⟹ ∃m. x = (TAtom OccursSecType, m)"
by (metis Γ⇩v_TAtom' surj_pair prot_atom.distinct(7),
metis Γ⇩v_TAtom' surj_pair prot_atom.distinct(15),
metis Γ⇩v_TAtom' surj_pair prot_atom.distinct(21),
metis Γ⇩v_TAtom' surj_pair prot_atom.distinct(25),
metis Γ⇩v_TAtom' surj_pair prot_atom.distinct(30))
lemma Γ⇩v_TAtom'':
"(fst x = TAtom (Atom a)) = (Γ⇩v x = TAtom (Atom a))" (is "?A = ?A'")
"(fst x = TAtom Value) = (Γ⇩v x = TAtom Value)" (is "?B = ?B'")
"(fst x = TAtom SetType) = (Γ⇩v x = TAtom SetType)" (is "?C = ?C'")
"(fst x = TAtom AttackType) = (Γ⇩v x = TAtom AttackType)" (is "?D = ?D'")
"(fst x = TAtom OccursSecType) = (Γ⇩v x = TAtom OccursSecType)" (is "?E = ?E'")
proof -
have 1: "?A ⟹ ?A'" "?B ⟹ ?B'" "?C ⟹ ?C'" "?D ⟹ ?D'" "?E ⟹ ?E'"
by (metis Γ⇩v_TAtom prod.collapse)+
have 2: "?A' ⟹ ?A" "?B' ⟹ ?B" "?C' ⟹ ?C" "?D' ⟹ ?D" "?E' ⟹ ?E"
using Γ⇩v_TAtom Γ⇩v_TAtom_inv(1) apply fastforce
using Γ⇩v_TAtom Γ⇩v_TAtom_inv(2) apply fastforce
using Γ⇩v_TAtom Γ⇩v_TAtom_inv(3) apply fastforce
using Γ⇩v_TAtom Γ⇩v_TAtom_inv(4) apply fastforce
using Γ⇩v_TAtom Γ⇩v_TAtom_inv(5) by fastforce
show "?A = ?A'" "?B = ?B'" "?C = ?C'" "?D = ?D'" "?E = ?E'"
using 1 2 by metis+
qed
lemma Γ⇩v_Var_image:
"Γ⇩v ` X = Γ ` Var ` X"
by force
lemma Γ_Fu_const:
assumes "arity⇩f g = 0"
shows "∃a. Γ (Fun (Fu g) T) = TAtom (Atom a)"
proof -
have "Γ⇩f g ≠ None" using assms Γ⇩f_assm by blast
thus ?thesis using assms by force
qed
lemma Fun_Value_type_inv:
fixes T::"('fun,'atom,'sets) prot_term list"
assumes "Γ (Fun f T) = TAtom Value"
shows "(∃n. f = Val n) ∨ (∃bs. f = Abs bs)"
proof -
have *: "arity f = 0" by (metis const_type_inv assms)
show ?thesis using assms
proof (cases f)
case (Fu g)
hence "arity⇩f g = 0" using * by simp
hence False using Fu Γ_Fu_const[of g T] assms by auto
thus ?thesis by metis
next
case (Set s)
hence "arity⇩s s = 0" using * by simp
hence False using Set assms by auto
thus ?thesis by metis
qed simp_all
qed
lemma abs_Γ: "Γ t = Γ (t ⋅⇩α α)"
by (induct t α rule: abs_apply_term.induct) auto
lemma Ana⇩f_keys_not_pubval_terms:
assumes "Ana⇩f f = (K, T)"
and "k ∈ set K"
and "g ∈ funs_term k"
shows "¬is_Val g"
proof
assume "is_Val g"
then obtain n S where *: "Fun (Val n) S ∈ subterms⇩s⇩e⇩t (set K)"
using assms(2) funs_term_Fun_subterm[OF assms(3)]
by (cases g) auto
show False using Ana⇩f_assm1_alt[OF assms(1) *] by simp
qed
lemma Ana⇩f_keys_not_abs_terms:
assumes "Ana⇩f f = (K, T)"
and "k ∈ set K"
and "g ∈ funs_term k"
shows "¬is_Abs g"
proof
assume "is_Abs g"
then obtain a S where *: "Fun (Abs a) S ∈ subterms⇩s⇩e⇩t (set K)"
using assms(2) funs_term_Fun_subterm[OF assms(3)]
by (cases g) auto
show False using Ana⇩f_assm1_alt[OF assms(1) *] by simp
qed
lemma Ana⇩f_keys_not_pairs:
assumes "Ana⇩f f = (K, T)"
and "k ∈ set K"
and "g ∈ funs_term k"
shows "g ≠ Pair"
proof
assume "g = Pair"
then obtain S where *: "Fun Pair S ∈ subterms⇩s⇩e⇩t (set K)"
using assms(2) funs_term_Fun_subterm[OF assms(3)]
by (cases g) auto
show False using Ana⇩f_assm1_alt[OF assms(1) *] by simp
qed
lemma Ana_Fu_keys_funs_term_subset:
fixes K::"('fun,'atom,'sets) prot_term list"
assumes "Ana (Fun (Fu f) S) = (K, T)"
and "Ana⇩f f = (K', T')"
shows "⋃(funs_term ` set K) ⊆ ⋃(funs_term ` set K') ∪ funs_term (Fun (Fu f) S)"
proof -
{ fix k assume k: "k ∈ set K"
then obtain k' where k':
"k' ∈ set K'" "k = k' ⋅ (!) S" "arity⇩f f = length S"
"subterms k' ⊆ subterms⇩s⇩e⇩t (set K')"
using assms Ana_Fu_elim[OF assms(1) _ assms(2)] by fastforce
have 1: "funs_term k' ⊆ ⋃(funs_term ` set K')" using k'(1) by auto
have "i < length S" when "i ∈ fv k'" for i
using that Ana⇩f_assm2_alt[OF assms(2), of i] k'(1,3)
by auto
hence 2: "funs_term (S ! i) ⊆ funs_term (Fun (Fu f) S)" when "i ∈ fv k'" for i
using that by force
have "funs_term k ⊆ ⋃(funs_term ` set K') ∪ funs_term (Fun (Fu f) S)"
using funs_term_subst[of k' "(!) S"] k'(2) 1 2 by fast
} thus ?thesis by blast
qed
lemma Ana_Fu_keys_not_pubval_terms:
fixes k::"('fun,'atom,'sets) prot_term"
assumes "Ana (Fun (Fu f) S) = (K, T)"
and "Ana⇩f f = (K', T')"
and "k ∈ set K"
and "∀g ∈ funs_term (Fun (Fu f) S). is_Val g ⟶ ¬public g"
shows "∀g ∈ funs_term k. is_Val g ⟶ ¬public g"
using assms(3,4) Ana⇩f_keys_not_pubval_terms[OF assms(2)]
Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
by blast
lemma Ana_Fu_keys_not_abs_terms:
fixes k::"('fun,'atom,'sets) prot_term"
assumes "Ana (Fun (Fu f) S) = (K, T)"
and "Ana⇩f f = (K', T')"
and "k ∈ set K"
and "∀g ∈ funs_term (Fun (Fu f) S). ¬is_Abs g"
shows "∀g ∈ funs_term k. ¬is_Abs g"
using assms(3,4) Ana⇩f_keys_not_abs_terms[OF assms(2)]
Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
by blast
lemma Ana_Fu_keys_not_pairs:
fixes k::"('fun,'atom,'sets) prot_term"
assumes "Ana (Fun (Fu f) S) = (K, T)"
and "Ana⇩f f = (K', T')"
and "k ∈ set K"
and "∀g ∈ funs_term (Fun (Fu f) S). g ≠ Pair"
shows "∀g ∈ funs_term k. g ≠ Pair"
using assms(3,4) Ana⇩f_keys_not_pairs[OF assms(2)]
Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
by blast
lemma deduct_occurs_in_ik:
fixes t::"('fun,'atom,'sets) prot_term"
assumes t: "M ⊢ occurs t"
and M: "∀s ∈ subterms⇩s⇩e⇩t M. OccursFact ∉ ⋃(funs_term ` set (snd (Ana s)))"
"∀s ∈ subterms⇩s⇩e⇩t M. OccursSec ∉ ⋃(funs_term ` set (snd (Ana s)))"
"Fun OccursSec [] ∉ M"
shows "occurs t ∈ M"
using private_fun_deduct_in_ik''[of M OccursFact "[Fun OccursSec [], t]" OccursSec] t M
by fastforce
lemma wellformed_transaction_sem_receives:
fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
assumes T_valid: "wellformed_transaction T"
and ℐ: "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ℐ"
and s: "receive⟨t⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
shows "IK ⊢ t ⋅ ℐ"
proof -
let ?R = "unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
let ?S = "λA. unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))"
let ?S' = "?S (transaction_receive T)"
obtain l B s where B:
"(l,send⟨t⟩) = dual⇩l⇩s⇩s⇩t⇩p ((l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ)"
"prefix ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ]) (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)"
using s dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(2)[of t "transaction_receive T ⋅⇩l⇩s⇩s⇩t θ"]
dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain_subst[of "send⟨t⟩" "transaction_receive T" θ]
by blast
have 1: "unlabel (dual⇩l⇩s⇩s⇩t ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ])) = unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[send⟨t⟩]"
using B(1) unlabel_append dual⇩l⇩s⇩s⇩t⇩p_subst dual⇩l⇩s⇩s⇩t_subst singleton_lst_proj(4)
dual⇩l⇩s⇩s⇩t_subst_snoc subst_lsst_append subst_lsst_singleton
by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps )
have "strand_sem_stateful IK DB ?S' ℐ"
using ℐ strand_sem_append_stateful[of IK DB _ _ ℐ] transaction_dual_subst_unfold[of T θ]
by fastforce
hence "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[send⟨t⟩]) ℐ"
using B 1 unfolding prefix_def unlabel_def
by (metis dual⇩l⇩s⇩s⇩t_def map_append strand_sem_append_stateful)
hence t_deduct: "IK ∪ (ik⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ)) ⋅⇩s⇩e⇩t ℐ) ⊢ t ⋅ ℐ"
using strand_sem_append_stateful[of IK DB "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" "[send⟨t⟩]" ℐ]
by simp
have "∀s ∈ set (unlabel (transaction_receive T)). ∃t. s = receive⟨t⟩"
using T_valid wellformed_transaction_unlabel_cases(1)[OF T_valid] by auto
moreover { fix A::"('fun,'atom,'sets,'lbl) prot_strand" and θ
assume "∀s ∈ set (unlabel A). ∃t. s = receive⟨t⟩"
hence "∀s ∈ set (unlabel (A ⋅⇩l⇩s⇩s⇩t θ)). ∃t. s = receive⟨t⟩"
proof (induction A)
case (Cons a A) thus ?case using subst_lsst_cons[of a A θ] by (cases a) auto
qed simp
hence "∀s ∈ set (unlabel (A ⋅⇩l⇩s⇩s⇩t θ)). ∃t. s = receive⟨t⟩"
by (simp add: list.pred_set is_Receive_def)
hence "∀s ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))). ∃t. s = send⟨t⟩"
by (metis dual⇩l⇩s⇩s⇩t_memberD dual⇩l⇩s⇩s⇩t⇩p_inv(2) unlabel_in unlabel_mem_has_label)
}
ultimately have "∀s ∈ set ?R. ∃t. s = send⟨t⟩" by simp
hence "ik⇩s⇩s⇩t ?R = {}" unfolding unlabel_def ik⇩s⇩s⇩t_def by fast
hence "ik⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ)) = {}"
using B(2) 1 ik⇩s⇩s⇩t_append dual⇩l⇩s⇩s⇩t_append
by (metis (no_types, lifting) Un_empty map_append prefix_def unlabel_def)
thus ?thesis using t_deduct by simp
qed
lemma wellformed_transaction_sem_selects:
assumes T_valid: "wellformed_transaction T"
and ℐ: "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ℐ"
and "select⟨t,u⟩ ∈ set (unlabel (transaction_selects T ⋅⇩l⇩s⇩s⇩t θ))"
shows "(t ⋅ ℐ, u ⋅ ℐ) ∈ DB"
proof -
let ?s = "select⟨t,u⟩"
let ?R = "transaction_receive T@transaction_selects T"
let ?R' = "unlabel (dual⇩l⇩s⇩s⇩t (?R ⋅⇩l⇩s⇩s⇩t θ))"
let ?S = "λA. unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))"
let ?S' = "?S (transaction_receive T)@?S (transaction_selects T)"
let ?P = "λa. is_Receive a ∨ is_Assignment a"
let ?Q = "λa. is_Send a ∨ is_Assignment a"
have s: "?s ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ))"
using assms(3) subst_lsst_append[of "transaction_receive T"]
unlabel_append[of "transaction_receive T ⋅⇩l⇩s⇩s⇩t θ"]
by auto
obtain l B s where B:
"(l,?s) = dual⇩l⇩s⇩s⇩t⇩p ((l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ)"
"prefix ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ]) (?R ⋅⇩l⇩s⇩s⇩t θ)"
using s dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(6)[of assign t u]
dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain_subst[of ?s ?R θ]
by blast
have 1: "unlabel (dual⇩l⇩s⇩s⇩t ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ])) = unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]"
using B(1) unlabel_append dual⇩l⇩s⇩s⇩t⇩p_subst dual⇩l⇩s⇩s⇩t_subst singleton_lst_proj(4)
dual⇩l⇩s⇩s⇩t_subst_snoc subst_lsst_append subst_lsst_singleton
by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps)
have "strand_sem_stateful IK DB ?S' ℐ"
using ℐ strand_sem_append_stateful[of IK DB _ _ ℐ] transaction_dual_subst_unfold[of T θ]
by fastforce
hence "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]) ℐ"
using B 1 strand_sem_append_stateful subst_lsst_append
unfolding prefix_def unlabel_def dual⇩l⇩s⇩s⇩t_def
by (metis (no_types) map_append)
hence in_db: "(t ⋅ ℐ, u ⋅ ℐ) ∈ dbupd⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))) ℐ DB"
using strand_sem_append_stateful[of IK DB "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" "[?s]" ℐ]
by simp
have "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ?Q a"
proof
fix a assume a: "a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ)))"
have "∀a ∈ set (unlabel ?R). ?P a"
using wellformed_transaction_unlabel_cases(1)[OF T_valid]
wellformed_transaction_unlabel_cases(2)[OF T_valid]
unfolding unlabel_def
by fastforce
hence "∀a ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using stateful_strand_step_cases_subst(2,8)[of _ θ] subst_lsst_unlabel[of ?R θ]
by (simp add: subst_apply_stateful_strand_def del: unlabel_append)
hence B_P: "∀a ∈ set (unlabel (B ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using unlabel_mono[OF set_mono_prefix[OF append_prefixD[OF B(2)]]]
by blast
obtain l where "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))"
using a by (meson unlabel_mem_has_label)
then obtain b where b: "(l,b) ∈ set (B ⋅⇩l⇩s⇩s⇩t θ)" "dual⇩l⇩s⇩s⇩t⇩p (l,b) = (l,a)"
using dual⇩l⇩s⇩s⇩t_memberD by blast
hence "?P b" using B_P unfolding unlabel_def by fastforce
thus "?Q a" using dual⇩l⇩s⇩s⇩t⇩p_inv[OF b(2)] by (cases b) auto
qed
hence "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ¬is_Insert a ∧ ¬is_Delete a" by fastforce
thus ?thesis using dbupd⇩s⇩s⇩t_no_upd[of "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" ℐ DB] in_db by simp
qed
lemma wellformed_transaction_sem_pos_checks:
assumes T_valid: "wellformed_transaction T"
and ℐ: "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ℐ"
and "⟨t in u⟩ ∈ set (unlabel (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ))"
shows "(t ⋅ ℐ, u ⋅ ℐ) ∈ DB"
proof -
let ?s = "⟨t in u⟩"
let ?R = "transaction_receive T@transaction_selects T@transaction_checks T"
let ?R' = "unlabel (dual⇩l⇩s⇩s⇩t (?R ⋅⇩l⇩s⇩s⇩t θ))"
let ?S = "λA. unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))"
let ?S' = "?S (transaction_receive T)@?S (transaction_selects T)@?S (transaction_checks T)"
let ?P = "λa. is_Receive a ∨ is_Assignment a ∨ is_Check a"
let ?Q = "λa. is_Send a ∨ is_Assignment a ∨ is_Check a"
have s: "?s ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ))"
using assms(3) subst_lsst_append[of "transaction_receive T@transaction_selects T"]
unlabel_append[of "transaction_receive T@transaction_selects T ⋅⇩l⇩s⇩s⇩t θ"]
by auto
obtain l B s where B:
"(l,?s) = dual⇩l⇩s⇩s⇩t⇩p ((l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ)"
"prefix ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ]) (?R ⋅⇩l⇩s⇩s⇩t θ)"
using s dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(6)[of check t u]
dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain_subst[of ?s ?R θ]
by blast
have 1: "unlabel (dual⇩l⇩s⇩s⇩t ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ])) = unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]"
using B(1) unlabel_append dual⇩l⇩s⇩s⇩t⇩p_subst dual⇩l⇩s⇩s⇩t_subst singleton_lst_proj(4)
dual⇩l⇩s⇩s⇩t_subst_snoc subst_lsst_append subst_lsst_singleton
by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps )
have "strand_sem_stateful IK DB ?S' ℐ"
using ℐ strand_sem_append_stateful[of IK DB _ _ ℐ] transaction_dual_subst_unfold[of T θ]
by fastforce
hence "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]) ℐ"
using B 1 strand_sem_append_stateful subst_lsst_append
unfolding prefix_def unlabel_def dual⇩l⇩s⇩s⇩t_def
by (metis (no_types) map_append)
hence in_db: "(t ⋅ ℐ, u ⋅ ℐ) ∈ dbupd⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))) ℐ DB"
using strand_sem_append_stateful[of IK DB "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" "[?s]" ℐ]
by simp
have "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ?Q a"
proof
fix a assume a: "a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ)))"
have "∀a ∈ set (unlabel ?R). ?P a"
using wellformed_transaction_unlabel_cases(1,2,3)[OF T_valid]
unfolding unlabel_def
by fastforce
hence "∀a ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using stateful_strand_step_cases_subst(2,8,9)[of _ θ] subst_lsst_unlabel[of ?R θ]
by (simp add: subst_apply_stateful_strand_def del: unlabel_append)
hence B_P: "∀a ∈ set (unlabel (B ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using unlabel_mono[OF set_mono_prefix[OF append_prefixD[OF B(2)]]]
by blast
obtain l where "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))"
using a by (meson unlabel_mem_has_label)
then obtain b where b: "(l,b) ∈ set (B ⋅⇩l⇩s⇩s⇩t θ)" "dual⇩l⇩s⇩s⇩t⇩p (l,b) = (l,a)"
using dual⇩l⇩s⇩s⇩t_memberD by blast
hence "?P b" using B_P unfolding unlabel_def by fastforce
thus "?Q a" using dual⇩l⇩s⇩s⇩t⇩p_inv[OF b(2)] by (cases b) auto
qed
hence "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ¬is_Insert a ∧ ¬is_Delete a" by fastforce
thus ?thesis using dbupd⇩s⇩s⇩t_no_upd[of "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" ℐ DB] in_db by simp
qed
lemma wellformed_transaction_sem_neg_checks:
assumes T_valid: "wellformed_transaction T"
and ℐ: "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ℐ"
and "NegChecks X [] [(t,u)] ∈ set (unlabel (transaction_checks T ⋅⇩l⇩s⇩s⇩t θ))"
shows "∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ (t ⋅ δ ⋅ ℐ, u ⋅ δ ⋅ ℐ) ∉ DB" (is ?A)
and "X = [] ⟹ (t ⋅ ℐ, u ⋅ ℐ) ∉ DB" (is "?B ⟹ ?B'")
proof -
let ?s = "NegChecks X [] [(t,u)]"
let ?R = "transaction_receive T@transaction_selects T@transaction_checks T"
let ?R' = "unlabel (dual⇩l⇩s⇩s⇩t (?R ⋅⇩l⇩s⇩s⇩t θ))"
let ?S = "λA. unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))"
let ?S' = "?S (transaction_receive T)@?S (transaction_selects T)@?S (transaction_checks T)"
let ?P = "λa. is_Receive a ∨ is_Assignment a ∨ is_Check a"
let ?Q = "λa. is_Send a ∨ is_Assignment a ∨ is_Check a"
let ?U = "λδ. subst_domain δ = set X ∧ ground (subst_range δ)"
have s: "?s ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ))"
using assms(3) subst_lsst_append[of "transaction_receive T@transaction_selects T"]
unlabel_append[of "transaction_receive T@transaction_selects T ⋅⇩l⇩s⇩s⇩t θ"]
by auto
obtain l B s where B:
"(l,?s) = dual⇩l⇩s⇩s⇩t⇩p ((l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ)"
"prefix ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ]) (?R ⋅⇩l⇩s⇩s⇩t θ)"
using s dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(7)[of X "[]" "[(t,u)]"]
dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain_subst[of ?s ?R θ]
by blast
have 1: "unlabel (dual⇩l⇩s⇩s⇩t ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ])) = unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]"
using B(1) unlabel_append dual⇩l⇩s⇩s⇩t⇩p_subst dual⇩l⇩s⇩s⇩t_subst singleton_lst_proj(4)
dual⇩l⇩s⇩s⇩t_subst_snoc subst_lsst_append subst_lsst_singleton
by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps)
have "strand_sem_stateful IK DB ?S' ℐ"
using ℐ strand_sem_append_stateful[of IK DB _ _ ℐ] transaction_dual_subst_unfold[of T θ]
by fastforce
hence "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))@[?s]) ℐ"
using B 1 strand_sem_append_stateful subst_lsst_append
unfolding prefix_def unlabel_def dual⇩l⇩s⇩s⇩t_def
by (metis (no_types) map_append)
hence "negchecks_model ℐ (dbupd⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))) ℐ DB) X [] [(t,u)]"
using strand_sem_append_stateful[of IK DB "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" "[?s]" ℐ]
by fastforce
hence in_db: "∀δ. ?U δ ⟶ (t ⋅ δ ⋅ ℐ, u ⋅ δ ⋅ ℐ) ∉ dbupd⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))) ℐ DB"
unfolding negchecks_model_def
by simp
have "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ?Q a"
proof
fix a assume a: "a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ)))"
have "∀a ∈ set (unlabel ?R). ?P a"
using wellformed_transaction_unlabel_cases(1,2,3)[OF T_valid]
unfolding unlabel_def
by fastforce
hence "∀a ∈ set (unlabel (?R ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using stateful_strand_step_cases_subst(2,8,9)[of _ θ] subst_lsst_unlabel[of ?R θ]
by (simp add: subst_apply_stateful_strand_def del: unlabel_append)
hence B_P: "∀a ∈ set (unlabel (B ⋅⇩l⇩s⇩s⇩t θ)). ?P a"
using unlabel_mono[OF set_mono_prefix[OF append_prefixD[OF B(2)]]]
by blast
obtain l where "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))"
using a by (meson unlabel_mem_has_label)
then obtain b where b: "(l,b) ∈ set (B ⋅⇩l⇩s⇩s⇩t θ)" "dual⇩l⇩s⇩s⇩t⇩p (l,b) = (l,a)"
using dual⇩l⇩s⇩s⇩t_memberD by blast
hence "?P b" using B_P unfolding unlabel_def by fastforce
thus "?Q a" using dual⇩l⇩s⇩s⇩t⇩p_inv[OF b(2)] by (cases b) auto
qed
hence "∀a ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))). ¬is_Insert a ∧ ¬is_Delete a" by fastforce
thus ?A using dbupd⇩s⇩s⇩t_no_upd[of "unlabel (dual⇩l⇩s⇩s⇩t (B ⋅⇩l⇩s⇩s⇩t θ))" ℐ DB] in_db by simp
moreover have "δ = Var" "t ⋅ δ = t"
when "subst_domain δ = set []" for t and δ::"('fun, 'atom, 'sets) prot_subst"
using that by auto
moreover have "subst_domain Var = set []" "range_vars Var = {}"
by simp_all
ultimately show "?B ⟹ ?B'" unfolding range_vars_alt_def by metis
qed
lemma wellformed_transaction_fv_in_receives_or_selects:
assumes T: "wellformed_transaction T"
and x: "x ∈ fv_transaction T" "x ∉ set (transaction_fresh T)"
shows "x ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
proof -
have "x ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T) ∪
fv⇩l⇩s⇩s⇩t (transaction_checks T) ∪ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪
fv⇩l⇩s⇩s⇩t (transaction_send T)"
using x(1) fv⇩s⇩s⇩t_append unlabel_append
by (metis transaction_strand_def append_assoc)
thus ?thesis using T x(2) unfolding wellformed_transaction_def by blast
qed
lemma dual_transaction_ik_is_transaction_send'':
fixes δ ℐ::"('a,'b,'c) prot_subst"
assumes "wellformed_transaction T"
shows "(ik⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ))) ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a =
(trms⇩s⇩s⇩t (unlabel (transaction_send T)) ⋅⇩s⇩e⇩t δ ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a" (is "?A = ?B")
using dual_transaction_ik_is_transaction_send[OF assms]
subst_lsst_unlabel[of "dual⇩l⇩s⇩s⇩t (transaction_strand T)" δ]
ik⇩s⇩s⇩t_subst[of "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T))" δ]
dual⇩l⇩s⇩s⇩t_subst[of "transaction_strand T" δ]
by (auto simp add: abs_apply_terms_def)
lemma while_prot_terms_fun_mono:
"mono (λM'. M ∪ ⋃(subterms ` M') ∪ ⋃((set ∘ fst ∘ Ana) ` M'))"
unfolding mono_def by fast
lemma while_prot_terms_SMP_overapprox:
fixes M::"('fun,'atom,'sets) prot_terms"
assumes N_supset: "M ∪ ⋃(subterms ` N) ∪ ⋃((set ∘ fst ∘ Ana) ` N) ⊆ N"
and Value_vars_only: "∀x ∈ fv⇩s⇩e⇩t N. Γ⇩v x = TAtom Value"
shows "SMP M ⊆ {a ⋅ δ | a δ. a ∈ N ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)}"
proof -
define f where "f ≡ λM'. M ∪ ⋃(subterms ` M') ∪ ⋃((set ∘ fst ∘ Ana) ` M')"
define S where "S ≡ {a ⋅ δ | a δ. a ∈ N ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)}"
note 0 = Value_vars_only
have "t ∈ S" when "t ∈ SMP M" for t
using that
proof (induction t rule: SMP.induct)
case (MP t)
hence "t ∈ N" "wt⇩s⇩u⇩b⇩s⇩t Var" "wf⇩t⇩r⇩m⇩s (subst_range Var)" using N_supset by auto
hence "t ⋅ Var ∈ S" unfolding S_def by blast
thus ?case by simp
next
case (Subterm t t')
then obtain δ a where a: "a ⋅ δ = t" "a ∈ N" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (auto simp add: S_def)
hence "∀x ∈ fv a. ∃τ. Γ (Var x) = TAtom τ" using 0 by auto
hence *: "∀x ∈ fv a. (∃f. δ x = Fun f []) ∨ (∃y. δ x = Var y)"
using a(3) TAtom_term_cases[OF wf_trm_subst_rangeD[OF a(4)]]
by (metis wt⇩s⇩u⇩b⇩s⇩t_def)
obtain b where b: "b ⋅ δ = t'" "b ∈ subterms a"
using subterms_subst_subterm[OF *, of t'] Subterm.hyps(2) a(1)
by fast
hence "b ∈ N" using N_supset a(2) by blast
thus ?case using a b(1) unfolding S_def by blast
next
case (Substitution t θ)
then obtain δ a where a: "a ⋅ δ = t" "a ∈ N" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (auto simp add: S_def)
have "wt⇩s⇩u⇩b⇩s⇩t (δ ∘⇩s θ)" "wf⇩t⇩r⇩m⇩s (subst_range (δ ∘⇩s θ))"
by (fact wt_subst_compose[OF a(3) Substitution.hyps(2)],
fact wf_trms_subst_compose[OF a(4) Substitution.hyps(3)])
moreover have "t ⋅ θ = a ⋅ δ ∘⇩s θ" using a(1) subst_subst_compose[of a δ θ] by simp
ultimately show ?case using a(2) unfolding S_def by blast
next
case (Ana t K T k)
then obtain δ a where a: "a ⋅ δ = t" "a ∈ N" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (auto simp add: S_def)
obtain Ka Ta where a': "Ana a = (Ka,Ta)" by moura
have *: "K = Ka ⋅⇩l⇩i⇩s⇩t δ"
proof (cases a)
case (Var x)
then obtain g U where gU: "t = Fun g U"
using a(1) Ana.hyps(2,3) Ana_var
by (cases t) simp_all
have "Γ (Var x) = TAtom Value" using Var a(2) 0 by auto
hence "Γ (Fun g U) = TAtom Value"
using a(1,3) Var gU wt_subst_trm''[OF a(3), of a]
by argo
thus ?thesis using gU Fun_Value_type_inv Ana.hyps(2,3) by fastforce
next
case (Fun g U) thus ?thesis using a(1) a' Ana.hyps(2) Ana_subst'[of g U] by simp
qed
then obtain ka where ka: "k = ka ⋅ δ" "ka ∈ set Ka" using Ana.hyps(3) by auto
have "ka ∈ set ((fst ∘ Ana) a)" using ka(2) a' by simp
hence "ka ∈ N" using a(2) N_supset by auto
thus ?case using ka a(3,4) unfolding S_def by blast
qed
thus ?thesis unfolding S_def by blast
qed
subsection ‹The Protocol Transition System, Defined in Terms of the Reachable Constraints›
definition transaction_fresh_subst where
"transaction_fresh_subst σ T 𝒜 ≡
subst_domain σ = set (transaction_fresh T) ∧
(∀t ∈ subst_range σ. ∃n. t = Fun (Val (n,False)) []) ∧
(∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)) ∧
(∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms_transaction T)) ∧
inj_on σ (subst_domain σ)"
definition transaction_renaming_subst where
"transaction_renaming_subst α P 𝒜 ≡
∃n ≥ max_var_set (⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t 𝒜). α = var_rename n"
definition constraint_model where
"constraint_model ℐ 𝒜 ≡
constr_sem_stateful ℐ (unlabel 𝒜) ∧
interpretation⇩s⇩u⇩b⇩s⇩t ℐ ∧
wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
definition welltyped_constraint_model where
"welltyped_constraint_model ℐ 𝒜 ≡ wt⇩s⇩u⇩b⇩s⇩t ℐ ∧ constraint_model ℐ 𝒜"
lemma constraint_model_prefix:
assumes "constraint_model I (A@B)"
shows "constraint_model I A"
by (metis assms strand_sem_append_stateful unlabel_append constraint_model_def)
lemma welltyped_constraint_model_prefix:
assumes "welltyped_constraint_model I (A@B)"
shows "welltyped_constraint_model I A"
by (metis assms constraint_model_prefix welltyped_constraint_model_def)
lemma constraint_model_Val_is_Value_term:
assumes "welltyped_constraint_model I A"
and "t ⋅ I = Fun (Val n) []"
shows "t = Fun (Val n) [] ∨ (∃m. t = Var (TAtom Value, m))"
proof -
have "wt⇩s⇩u⇩b⇩s⇩t I" using assms(1) unfolding welltyped_constraint_model_def by simp
moreover have "Γ (Fun (Val n) []) = TAtom Value" by auto
ultimately have *: "Γ t = TAtom Value" by (metis (no_types) assms(2) wt_subst_trm'')
show ?thesis
proof (cases t)
case (Var x)
obtain τ m where x: "x = (τ, m)" by (metis surj_pair)
have "Γ⇩v x = TAtom Value" using * Var by auto
hence "τ = TAtom Value" using x Γ⇩v_TAtom'[of Value τ m] by simp
thus ?thesis using x Var by metis
next
case (Fun f T) thus ?thesis using assms(2) by auto
qed
qed
text ‹
The set of symbolic constraints reachable in any symbolic run of the protocol ‹P›.
‹σ› instantiates the fresh variables of transaction ‹T› with fresh terms.
‹α› is a variable-renaming whose range consists of fresh variables.
›
inductive_set reachable_constraints::
"('fun,'atom,'sets,'lbl) prot ⇒ ('fun,'atom,'sets,'lbl) prot_constr set"
for P::"('fun,'atom,'sets,'lbl) prot"
where
init:
"[] ∈ reachable_constraints P"
| step:
"⟦𝒜 ∈ reachable_constraints P;
T ∈ set P;
transaction_fresh_subst σ T 𝒜;
transaction_renaming_subst α P 𝒜
⟧ ⟹ 𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α) ∈ reachable_constraints P"
subsection ‹Admissible Transactions›
definition admissible_transaction_checks where
"admissible_transaction_checks T ≡
∀x ∈ set (unlabel (transaction_checks T)).
is_Check x ∧
(is_InSet x ⟶
is_Var (the_elem_term x) ∧ is_Fun_Set (the_set_term x) ∧
fst (the_Var (the_elem_term x)) = TAtom Value) ∧
(is_NegChecks x ⟶
bvars⇩s⇩s⇩t⇩p x = [] ∧
((the_eqs x = [] ∧ length (the_ins x) = 1) ∨
(the_ins x = [] ∧ length (the_eqs x) = 1))) ∧
(is_NegChecks x ∧ the_eqs x = [] ⟶ (let h = hd (the_ins x) in
is_Var (fst h) ∧ is_Fun_Set (snd h) ∧
fst (the_Var (fst h)) = TAtom Value))"
definition admissible_transaction_selects where
"admissible_transaction_selects T ≡
∀x ∈ set (unlabel (transaction_selects T)).
is_InSet x ∧ the_check x = Assign ∧ is_Var (the_elem_term x) ∧ is_Fun_Set (the_set_term x) ∧
fst (the_Var (the_elem_term x)) = TAtom Value"
definition admissible_transaction_updates where
"admissible_transaction_updates T ≡
∀x ∈ set (unlabel (transaction_updates T)).
is_Update x ∧ is_Var (the_elem_term x) ∧ is_Fun_Set (the_set_term x) ∧
fst (the_Var (the_elem_term x)) = TAtom Value"
definition admissible_transaction_terms where
"admissible_transaction_terms T ≡
wf⇩t⇩r⇩m⇩s' arity (trms⇩l⇩s⇩s⇩t (transaction_strand T)) ∧
(∀f ∈ ⋃(funs_term ` trms_transaction T).
¬is_Val f ∧ ¬is_Abs f ∧ ¬is_PubConstSetType f ∧ f ≠ Pair ∧
¬is_PubConstAttackType f ∧ ¬is_PubConstBottom f ∧ ¬is_PubConstOccursSecType f) ∧
(∀r ∈ set (unlabel (transaction_strand T)).
(∃f ∈ ⋃(funs_term ` (trms⇩s⇩s⇩t⇩p r)). is_Attack f) ⟶
(let t = the_msg r in is_Send r ∧ is_Fun t ∧ is_Attack (the_Fun t) ∧ args t = []))"
definition admissible_transaction_occurs_checks where
"admissible_transaction_occurs_checks T ≡ (
(∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶
receive⟨occurs (Var x)⟩ ∈ set (unlabel (transaction_receive T))) ∧
(∀x ∈ set (transaction_fresh T). fst x = TAtom Value ⟶
send⟨occurs (Var x)⟩ ∈ set (unlabel (transaction_send T))) ∧
(∀r ∈ set (unlabel (transaction_receive T)). is_Receive r ⟶
(OccursFact ∈ funs_term (the_msg r) ∨ OccursSec ∈ funs_term (the_msg r)) ⟶
(∃x ∈ fv_transaction T - set (transaction_fresh T).
fst x = TAtom Value ∧ the_msg r = occurs (Var x))) ∧
(∀r ∈ set (unlabel (transaction_send T)). is_Send r ⟶
(OccursFact ∈ funs_term (the_msg r) ∨ OccursSec ∈ funs_term (the_msg r)) ⟶
(∃x ∈ set (transaction_fresh T).
fst x = TAtom Value ∧ the_msg r = occurs (Var x)))
)"
definition admissible_transaction where
"admissible_transaction T ≡ (
wellformed_transaction T ∧
distinct (transaction_fresh T) ∧
list_all (λx. fst x = TAtom Value) (transaction_fresh T) ∧
(∀x ∈ vars⇩l⇩s⇩s⇩t (transaction_strand T). is_Var (fst x) ∧ (the_Var (fst x) = Value)) ∧
bvars⇩l⇩s⇩s⇩t (transaction_strand T) = {} ∧
(∀x ∈ fv_transaction T - set (transaction_fresh T).
∀y ∈ fv_transaction T - set (transaction_fresh T).
x ≠ y ⟶ ⟨Var x != Var y⟩ ∈ set (unlabel (transaction_checks T)) ∨
⟨Var y != Var x⟩ ∈ set (unlabel (transaction_checks T))) ∧
admissible_transaction_selects T ∧
admissible_transaction_checks T ∧
admissible_transaction_updates T ∧
admissible_transaction_terms T ∧
admissible_transaction_occurs_checks T
)"
lemma transaction_no_bvars:
assumes "admissible_transaction T"
shows "fv_transaction T = vars_transaction T"
and "bvars_transaction T = {}"
proof -
have "wellformed_transaction T" "bvars⇩l⇩s⇩s⇩t (transaction_strand T) = {}"
using assms unfolding admissible_transaction_def
by blast+
thus "bvars_transaction T = {}" "fv_transaction T = vars_transaction T"
using bvars_wellformed_transaction_unfold vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t
by fast+
qed
lemma transactions_fv_bvars_disj:
assumes "∀T ∈ set P. admissible_transaction T"
shows "(⋃T ∈ set P. fv_transaction T) ∩ (⋃T ∈ set P. bvars_transaction T) = {}"
using assms transaction_no_bvars(2) by fast
lemma transaction_bvars_no_Value_type:
assumes "admissible_transaction T"
and "x ∈ bvars_transaction T"
shows "¬TAtom Value ⊑ Γ⇩v x"
using assms transaction_no_bvars(2) by blast
lemma transaction_receive_deduct:
assumes T_adm: "admissible_transaction T"
and ℐ: "constraint_model ℐ (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T A"
and α: "transaction_renaming_subst α P A"
and t: "receive⟨t⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
shows "ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
proof -
define θ where "θ ≡ σ ∘⇩s α"
have t': "send⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)))"
using t dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(2) unfolding θ_def by blast
then obtain T1 T2 where T: "unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)) = T1@send⟨t⟩#T2"
using t' by (meson split_list)
have "constr_sem_stateful ℐ (unlabel A@unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)))"
using ℐ unlabel_append[of A] unfolding constraint_model_def θ_def by simp
hence "constr_sem_stateful ℐ (unlabel A@T1@[send⟨t⟩])"
using strand_sem_append_stateful[of "{}" "{}" "unlabel A@T1@[send⟨t⟩]" _ ℐ]
transaction_dual_subst_unfold[of T θ] T
by (metis append.assoc append_Cons append_Nil)
hence "ik⇩s⇩s⇩t (unlabel A@T1) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
using strand_sem_append_stateful[of "{}" "{}" "unlabel A@T1" "[send⟨t⟩]" ℐ] T
by force
moreover have "¬is_Receive x"
when x: "x ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)))" for x
proof -
have *: "is_Receive a" when "a ∈ set (unlabel (transaction_receive T))" for a
using T_adm Ball_set[of "unlabel (transaction_receive T)" is_Receive] that
unfolding admissible_transaction_def wellformed_transaction_def
by blast
obtain l where l: "(l,x) ∈ set (dual⇩l⇩s⇩s⇩t (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
using x unfolding unlabel_def by fastforce
then obtain ly where ly: "ly ∈ set (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)" "(l,x) = dual⇩l⇩s⇩s⇩t⇩p ly"
unfolding dual⇩l⇩s⇩s⇩t_def by auto
obtain j y where j: "ly = (j,y)" by (metis surj_pair)
hence "j = l" using ly(2) by (cases y) auto
hence y: "(l,y) ∈ set (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ)" "(l,x) = dual⇩l⇩s⇩s⇩t⇩p (l,y)"
by (metis j ly(1), metis j ly(2))
obtain z where z:
"z ∈ set (unlabel (transaction_receive T))"
"(l,z) ∈ set (transaction_receive T)"
"(l,y) = (l,z) ⋅⇩l⇩s⇩s⇩t⇩p θ"
using y(1) unfolding subst_apply_labeled_stateful_strand_def unlabel_def by force
have "is_Receive y" using *[OF z(1)] z(3) by (cases z) auto
thus "¬is_Receive x" using l y by (cases y) auto
qed
hence "¬is_Receive x" when "x ∈ set T1" for x using T that by simp
hence "ik⇩s⇩s⇩t T1 = {}" unfolding ik⇩s⇩s⇩t_def is_Receive_def by fast
hence "ik⇩s⇩s⇩t (unlabel A@T1) = ik⇩l⇩s⇩s⇩t A" using ik⇩s⇩s⇩t_append[of "unlabel A" T1] by simp
ultimately show ?thesis by (simp add: θ_def)
qed
lemma transaction_checks_db:
assumes T: "admissible_transaction T"
and ℐ: "constraint_model ℐ (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T A"
and α: "transaction_renaming_subst α P A"
shows "⟨Var (TAtom Value, n) in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))
⟹ (α (TAtom Value, n) ⋅ ℐ, Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t A ℐ)"
(is "?A ⟹ ?B")
and "⟨Var (TAtom Value, n) not in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))
⟹ (α (TAtom Value, n) ⋅ ℐ, Fun (Set s) []) ∉ set (db⇩l⇩s⇩s⇩t A ℐ)"
(is "?C ⟹ ?D")
proof -
let ?x = "λn. (TAtom Value, n)"
let ?s = "Fun (Set s) []"
let ?T = "transaction_receive T@transaction_selects T@transaction_checks T"
let ?T' = "?T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
let ?S = "λS. transaction_receive T@transaction_selects T@S"
let ?S' = "λS. ?S S ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
have T_valid: "wellformed_transaction T" using T by (simp add: admissible_transaction_def)
have "constr_sem_stateful ℐ (unlabel (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
using ℐ unfolding constraint_model_def by simp
moreover have
"dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ) =
dual⇩l⇩s⇩s⇩t (?S (T1@[c]) ⋅⇩l⇩s⇩s⇩t δ)@
dual⇩l⇩s⇩s⇩t (T2@transaction_updates T@transaction_send T ⋅⇩l⇩s⇩s⇩t δ)"
when "transaction_checks T = T1@c#T2" for T1 T2 c δ
using that dual⇩l⇩s⇩s⇩t_append subst_lsst_append
unfolding transaction_strand_def
by (metis append.assoc append_Cons append_Nil)
ultimately have T'_model: "constr_sem_stateful ℐ (unlabel (A@dual⇩l⇩s⇩s⇩t (?S' (T1@[(l,c)]))))"
when "transaction_checks T = T1@(l,c)#T2" for T1 T2 l c
using strand_sem_append_stateful[of _ _ _ _ ℐ]
by (simp add: that transaction_strand_def)
show "?A ⟹ ?B"
proof -
assume a: ?A
hence *: "⟨Var (?x n) in ?s⟩ ∈ set (unlabel ?T)"
unfolding transaction_strand_def unlabel_def by simp
then obtain l T1 T2 where T1: "transaction_checks T = T1@(l,⟨Var (?x n) in ?s⟩)#T2"
by (metis a split_list unlabel_mem_has_label)
have "?x n ∈ fv⇩l⇩s⇩s⇩t (transaction_checks T)"
using a by force
hence "?x n ∉ set (transaction_fresh T)"
using a transaction_fresh_vars_notin[OF T_valid] by fast
hence "unlabel (A@dual⇩l⇩s⇩s⇩t (?S' (T1@[(l,⟨Var (?x n) in ?s⟩)]))) =
unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1))@[⟨α (?x n) in ?s⟩]"
using T a σ dual⇩l⇩s⇩s⇩t_append subst_lsst_append unlabel_append
by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual⇩l⇩s⇩s⇩t_def
subst_apply_labeled_stateful_strand_def)
moreover have "db⇩s⇩s⇩t (unlabel A) = db⇩s⇩s⇩t (unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1)))"
by (simp add: T1 db⇩s⇩s⇩t_transaction_prefix_eq[OF T_valid] del: unlabel_append)
ultimately have "∃M. strand_sem_stateful M (set (db⇩s⇩s⇩t (unlabel A) ℐ)) [⟨α (?x n) in ?s⟩] ℐ"
using T'_model[OF T1] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of _ ℐ] strand_sem_append_stateful[of _ _ _ _ ℐ]
by (simp add: db⇩s⇩s⇩t_def del: unlabel_append)
thus ?B by simp
qed
show "?C ⟹ ?D"
proof -
assume a: ?C
hence *: "⟨Var (?x n) not in ?s⟩ ∈ set (unlabel ?T)"
unfolding transaction_strand_def unlabel_def by simp
then obtain l T1 T2 where T1: "transaction_checks T = T1@(l,⟨Var (?x n) not in ?s⟩)#T2"
by (metis a split_list unlabel_mem_has_label)
have "?x n ∈ vars⇩s⇩s⇩t⇩p ⟨Var (?x n) not in ?s⟩"
using vars⇩s⇩s⇩t⇩p_cases(9)[of "[]" "Var (?x n)" ?s] by auto
hence "?x n ∈ vars⇩l⇩s⇩s⇩t (transaction_checks T)"
using a unfolding vars⇩s⇩s⇩t_def by force
hence "?x n ∉ set (transaction_fresh T)"
using a transaction_fresh_vars_notin[OF T_valid] by fast
hence "unlabel (A@dual⇩l⇩s⇩s⇩t (?S' (T1@[(l,⟨Var (?x n) not in ?s⟩)]))) =
unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1))@[⟨α (?x n) not in ?s⟩]"
using T a σ dual⇩l⇩s⇩s⇩t_append subst_lsst_append unlabel_append
by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual⇩l⇩s⇩s⇩t_def
subst_apply_labeled_stateful_strand_def)
moreover have "db⇩s⇩s⇩t (unlabel A) = db⇩s⇩s⇩t (unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1)))"
by (simp add: T1 db⇩s⇩s⇩t_transaction_prefix_eq[OF T_valid] del: unlabel_append)
ultimately have "∃M. strand_sem_stateful M (set (db⇩s⇩s⇩t (unlabel A) ℐ)) [⟨α (?x n) not in ?s⟩] ℐ"
using T'_model[OF T1] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of _ ℐ] strand_sem_append_stateful[of _ _ _ _ ℐ]
by (simp add: db⇩s⇩s⇩t_def del: unlabel_append)
thus ?D using stateful_strand_sem_NegChecks_no_bvars(1)[of _ _ _ ?s ℐ] by simp
qed
qed
lemma transaction_selects_db:
assumes T: "admissible_transaction T"
and ℐ: "constraint_model ℐ (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T A"
and α: "transaction_renaming_subst α P A"
shows "select⟨Var (TAtom Value, n), Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))
⟹ (α (TAtom Value, n) ⋅ ℐ, Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t A ℐ)"
(is "?A ⟹ ?B")
proof -
let ?x = "λn. (TAtom Value, n)"
let ?s = "Fun (Set s) []"
let ?T = "transaction_receive T@transaction_selects T@transaction_checks T"
let ?T' = "?T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
let ?S = "λS. transaction_receive T@S"
let ?S' = "λS. ?S S ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
have T_valid: "wellformed_transaction T" using T by (simp add: admissible_transaction_def)
have "constr_sem_stateful ℐ (unlabel (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
using ℐ unfolding constraint_model_def by simp
moreover have
"dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t δ) =
dual⇩l⇩s⇩s⇩t (?S (T1@[c]) ⋅⇩l⇩s⇩s⇩t δ)@
dual⇩l⇩s⇩s⇩t (T2@transaction_checks T @ transaction_updates T@transaction_send T ⋅⇩l⇩s⇩s⇩t δ)"
when "transaction_selects T = T1@c#T2" for T1 T2 c δ
using that dual⇩l⇩s⇩s⇩t_append subst_lsst_append
unfolding transaction_strand_def by (metis append.assoc append_Cons append_Nil)
ultimately have T'_model: "constr_sem_stateful ℐ (unlabel (A@dual⇩l⇩s⇩s⇩t (?S' (T1@[(l,c)]))))"
when "transaction_selects T = T1@(l,c)#T2" for T1 T2 l c
using strand_sem_append_stateful[of _ _ _ _ ℐ]
by (simp add: that transaction_strand_def)
show "?A ⟹ ?B"
proof -
assume a: ?A
hence *: "select⟨Var (?x n), ?s⟩ ∈ set (unlabel ?T)"
unfolding transaction_strand_def unlabel_def by simp
then obtain l T1 T2 where T1: "transaction_selects T = T1@(l,select⟨Var (?x n), ?s⟩)#T2"
by (metis a split_list unlabel_mem_has_label)
have "?x n ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using a by force
hence "?x n ∉ set (transaction_fresh T)"
using a transaction_fresh_vars_notin[OF T_valid] by fast
hence "unlabel (A@dual⇩l⇩s⇩s⇩t (?S' (T1@[(l,select⟨Var (?x n), ?s⟩)]))) =
unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1))@[select⟨α (?x n), ?s⟩]"
using T a σ dual⇩l⇩s⇩s⇩t_append subst_lsst_append unlabel_append
by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual⇩l⇩s⇩s⇩t_def
subst_apply_labeled_stateful_strand_def)
moreover have "db⇩s⇩s⇩t (unlabel A) = db⇩s⇩s⇩t (unlabel (A@dual⇩l⇩s⇩s⇩t (?S' T1)))"
by (simp add: T1 db⇩s⇩s⇩t_transaction_prefix_eq[OF T_valid] del: unlabel_append)
ultimately have "∃M. strand_sem_stateful M (set (db⇩s⇩s⇩t (unlabel A) ℐ)) [⟨α (?x n) in ?s⟩] ℐ"
using T'_model[OF T1] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of _ ℐ] strand_sem_append_stateful[of _ _ _ _ ℐ]
by (simp add: db⇩s⇩s⇩t_def del: unlabel_append)
thus ?B by simp
qed
qed
lemma transactions_have_no_Value_consts:
assumes "admissible_transaction T"
and "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_strand T))"
shows "∄a T. t = Fun (Val a) T" (is ?A)
and "∄a T. t = Fun (Abs a) T" (is ?B)
proof -
have "admissible_transaction_terms T" using assms(1) unfolding admissible_transaction_def by blast
hence "¬is_Val f" "¬is_Abs f"
when "f ∈ ⋃(funs_term ` (trms_transaction T))" for f
using that unfolding admissible_transaction_terms_def by blast+
moreover have "f ∈ ⋃(funs_term ` (trms_transaction T))"
when "f ∈ funs_term t" for f
using that assms(2) funs_term_subterms_eq(2)[of "trms_transaction T"] by blast+
ultimately have *: "¬is_Val f" "¬is_Abs f"
when "f ∈ funs_term t" for f
using that by presburger+
show ?A using *(1) by force
show ?B using *(2) by force
qed
lemma transactions_have_no_Value_consts':
assumes "admissible_transaction T"
and "t ∈ trms⇩l⇩s⇩s⇩t (transaction_strand T)"
shows "∄a T. Fun (Val a) T ∈ subterms t"
and "∄a T. Fun (Abs a) T ∈ subterms t"
using transactions_have_no_Value_consts[OF assms(1)] assms(2) by fast+
lemma transactions_have_no_PubConsts:
assumes "admissible_transaction T"
and "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_strand T))"
shows "∄a T. t = Fun (PubConstSetType a) T" (is ?A)
and "∄a T. t = Fun (PubConstAttackType a) T" (is ?B)
and "∄a T. t = Fun (PubConstBottom a) T" (is ?C)
and "∄a T. t = Fun (PubConstOccursSecType a) T" (is ?D)
proof -
have "admissible_transaction_terms T" using assms(1) unfolding admissible_transaction_def by blast
hence "¬is_PubConstSetType f" "¬is_PubConstAttackType f"
"¬is_PubConstBottom f" "¬is_PubConstOccursSecType f"
when "f ∈ ⋃(funs_term ` (trms_transaction T))" for f
using that unfolding admissible_transaction_terms_def by blast+
moreover have "f ∈ ⋃(funs_term ` (trms_transaction T))"
when "f ∈ funs_term t" for f
using that assms(2) funs_term_subterms_eq(2)[of "trms_transaction T"] by blast+
ultimately have *:
"¬is_PubConstSetType f" "¬is_PubConstAttackType f"
"¬is_PubConstBottom f" "¬is_PubConstOccursSecType f"
when "f ∈ funs_term t" for f
using that by presburger+
show ?A using *(1) by force
show ?B using *(2) by force
show ?C using *(3) by force
show ?D using *(4) by force
qed
lemma transactions_have_no_PubConsts':
assumes "admissible_transaction T"
and "t ∈ trms⇩l⇩s⇩s⇩t (transaction_strand T)"
shows "∄a T. Fun (PubConstSetType a) T ∈ subterms t"
and "∄a T. Fun (PubConstAttackType a) T ∈ subterms t"
and "∄a T. Fun (PubConstBottom a) T ∈ subterms t"
and "∄a T. Fun (PubConstOccursSecType a) T ∈ subterms t"
using transactions_have_no_PubConsts[OF assms(1)] assms(2) by fast+
lemma transaction_inserts_are_Value_vars:
assumes T_valid: "wellformed_transaction T"
and "admissible_transaction_updates T"
and "insert⟨t,s⟩ ∈ set (unlabel (transaction_strand T))"
shows "∃n. t = Var (TAtom Value, n)"
and "∃u. s = Fun (Set u) []"
proof -
let ?x = "insert⟨t,s⟩"
have "?x ∈ set (unlabel (transaction_updates T))"
using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]
by (auto simp add: transaction_strand_def unlabel_def)
hence *: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
"is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
"is_Set (the_Fun (the_set_term ?x))"
using assms(2) unfolding admissible_transaction_updates_def is_Fun_Set_def by fastforce+
show "∃n. t = Var (TAtom Value, n)" using *(1,2) by (cases t) auto
show "∃u. s = Fun (Set u) []" using *(3,4,5) unfolding is_Set_def by (cases s) auto
qed
lemma transaction_deletes_are_Value_vars:
assumes T_valid: "wellformed_transaction T"
and "admissible_transaction_updates T"
and "delete⟨t,s⟩ ∈ set (unlabel (transaction_strand T))"
shows "∃n. t = Var (TAtom Value, n)"
and "∃u. s = Fun (Set u) []"
proof -
let ?x = "delete⟨t,s⟩"
have "?x ∈ set (unlabel (transaction_updates T))"
using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]
by (auto simp add: transaction_strand_def unlabel_def)
hence *: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
"is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
"is_Set (the_Fun (the_set_term ?x))"
using assms(2) unfolding admissible_transaction_updates_def is_Fun_Set_def by fastforce+
show "∃n. t = Var (TAtom Value, n)" using *(1,2) by (cases t) auto
show "∃u. s = Fun (Set u) []" using *(3,4,5) unfolding is_Set_def by (cases s) auto
qed
lemma transaction_selects_are_Value_vars:
assumes T_valid: "wellformed_transaction T"
and "admissible_transaction_selects T"
and "select⟨t,s⟩ ∈ set (unlabel (transaction_strand T))"
shows "∃n. t = Var (TAtom Value, n) ∧ (TAtom Value, n) ∉ set (transaction_fresh T)" (is ?A)
and "∃u. s = Fun (Set u) []" (is ?B)
proof -
let ?x = "select⟨t,s⟩"
have *: "?x ∈ set (unlabel (transaction_selects T))"
using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]
by (auto simp add: transaction_strand_def unlabel_def)
have **: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
"is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
"is_Set (the_Fun (the_set_term ?x))"
using * assms(2) unfolding admissible_transaction_selects_def is_Fun_Set_def by fastforce+
have "fv⇩s⇩s⇩t⇩p ?x ⊆ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using * by force
hence ***: "fv⇩s⇩s⇩t⇩p ?x ∩ set (transaction_fresh T) = {}"
using T_valid unfolding wellformed_transaction_def by fast
show ?A using **(1,2) *** by (cases t) auto
show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
qed
lemma transaction_inset_checks_are_Value_vars:
assumes T_valid: "wellformed_transaction T"
and "admissible_transaction_checks T"
and "⟨t in s⟩ ∈ set (unlabel (transaction_strand T))"
shows "∃n. t = Var (TAtom Value, n) ∧ (TAtom Value, n) ∉ set (transaction_fresh T)" (is ?A)
and "∃u. s = Fun (Set u) []" (is ?B)
proof -
let ?x = "⟨t in s⟩"
have *: "?x ∈ set (unlabel (transaction_checks T))"
using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]
by (auto simp add: transaction_strand_def unlabel_def)
have **: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
"is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
"is_Set (the_Fun (the_set_term ?x))"
using * assms(2) unfolding admissible_transaction_checks_def is_Fun_Set_def by fastforce+
have "fv⇩s⇩s⇩t⇩p ?x ⊆ fv⇩l⇩s⇩s⇩t (transaction_checks T)"
using * by force
hence ***: "fv⇩s⇩s⇩t⇩p ?x ∩ set (transaction_fresh T) = {}"
using T_valid unfolding wellformed_transaction_def by fast
show ?A using **(1,2) *** by (cases t) auto
show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
qed
lemma transaction_notinset_checks_are_Value_vars:
assumes T_valid: "wellformed_transaction T"
and "admissible_transaction_checks T"
and "∀X⟨∨≠: F ∨∉: G⟩ ∈ set (unlabel (transaction_strand T))"
and "(t,s) ∈ set G"
shows "∃n. t = Var (TAtom Value, n) ∧ (TAtom Value, n) ∉ set (transaction_fresh T)" (is ?A)
and "∃u. s = Fun (Set u) []" (is ?B)
proof -
let ?x = "∀X⟨∨≠: F ∨∉: G⟩"
have 0: "?x ∈ set (unlabel (transaction_checks T))"
using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]
by (auto simp add: transaction_strand_def unlabel_def)
hence 1: "F = [] ∧ length G = 1"
using assms(2,4) unfolding admissible_transaction_checks_def by fastforce
hence "hd G = (t,s)" using assms(4) by (cases "the_ins ?x") auto
hence **: "is_Var t" "fst (the_Var t) = TAtom Value" "is_Fun s" "args s = []" "is_Set (the_Fun s)"
using 0 1 assms(2) unfolding admissible_transaction_checks_def Let_def is_Fun_Set_def
by fastforce+
have "fv⇩s⇩s⇩t⇩p ?x ⊆ fv⇩l⇩s⇩s⇩t (transaction_checks T)"
"set (bvars⇩s⇩s⇩t⇩p ?x) ⊆ bvars⇩l⇩s⇩s⇩t (transaction_checks T)"
using 0 by force+
moreover have
"fv⇩l⇩s⇩s⇩t (transaction_checks T) ⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∪ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
"set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_receive T) = {}"
"set (transaction_fresh T) ∩ fv⇩l⇩s⇩s⇩t (transaction_selects T) = {}"
using T_valid unfolding wellformed_transaction_def by fast+
ultimately have
"fv⇩s⇩s⇩t⇩p ?x ∩ set (transaction_fresh T) = {}"
"set (bvars⇩s⇩s⇩t⇩p ?x) ∩ set (transaction_fresh T) = {}"
using wellformed_transaction_wf⇩s⇩s⇩t(2,3)[OF T_valid]
fv_transaction_unfold[of T] bvars_transaction_unfold[of T]
by blast+
hence ***: "fv t ∩ set (transaction_fresh T) = {}"
using assms(4) by auto
show ?A using **(1,2) *** by (cases t) auto
show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
qed
lemma admissible_transaction_strand_step_cases:
assumes T_adm: "admissible_transaction T"
shows "r ∈ set (unlabel (transaction_receive T)) ⟹ ∃t. r = receive⟨t⟩"
(is "?A ⟹ ?A'")
and "r ∈ set (unlabel (transaction_selects T)) ⟹
∃x s. r = select⟨Var x, Fun (Set s) []⟩ ∧
fst x = TAtom Value ∧ x ∈ fv_transaction T - set (transaction_fresh T)"
(is "?B ⟹ ?B'")
and "r ∈ set (unlabel (transaction_checks T)) ⟹
(∃x s. (r = ⟨Var x in Fun (Set s) []⟩ ∨ r = ⟨Var x not in Fun (Set s) []⟩) ∧
fst x = TAtom Value ∧ x ∈ fv_transaction T - set (transaction_fresh T)) ∨
(∃s t. r = ⟨s == t⟩ ∨ r = ⟨s != t⟩)"
(is "?C ⟹ ?C'")
and "r ∈ set (unlabel (transaction_updates T)) ⟹
∃x s. (r = insert⟨Var x, Fun (Set s) []⟩ ∨ r = delete⟨Var x, Fun (Set s) []⟩) ∧
fst x = TAtom Value"
(is "?D ⟹ ?D'")
and "r ∈ set (unlabel (transaction_send T)) ⟹ ∃t. r = send⟨t⟩"
(is "?E ⟹ ?E'")
proof -
have T_valid: "wellformed_transaction T"
using T_adm unfolding admissible_transaction_def by metis
show "?A ⟹ ?A'"
using T_valid Ball_set[of "unlabel (transaction_receive T)" is_Receive]
unfolding wellformed_transaction_def is_Receive_def
by blast
show "?E ⟹ ?E'"
using T_valid Ball_set[of "unlabel (transaction_send T)" is_Send]
unfolding wellformed_transaction_def is_Send_def
by blast
show "?B ⟹ ?B'"
proof -
assume r: ?B
have "admissible_transaction_selects T"
using T_adm unfolding admissible_transaction_def by simp
hence *: "is_InSet r" "the_check r = Assign" "is_Var (the_elem_term r)"
"is_Fun (the_set_term r)" "is_Set (the_Fun (the_set_term r))"
"args (the_set_term r) = []" "fst (the_Var (the_elem_term r)) = TAtom Value"
using r unfolding admissible_transaction_selects_def is_Fun_Set_def
by fast+
obtain rt rs where r': "r = select⟨rt,rs⟩" using *(1,2) by (cases r) auto
obtain x where x: "rt = Var x" "fst x = TAtom Value" using *(3,7) r' by auto
obtain f S where fS: "rs = Fun f S" using *(4) r' by auto
obtain s where s: "f = Set s" using *(5) fS r' by (cases f) auto
hence S: "S = []" using *(6) fS r' by (cases S) auto
have fv_r1: "fv⇩s⇩s⇩t⇩p r ⊆ fv_transaction T"
using r fv_transaction_unfold[of T] by auto
have fv_r2: "fv⇩s⇩s⇩t⇩p r ∩ set (transaction_fresh T) = {}"
using r T_valid unfolding wellformed_transaction_def by fastforce
show ?B' using r' x fS s S fv_r1 fv_r2 by simp
qed
show "?C ⟹ ?C'"
proof -
assume r: ?C
have adm_checks: "admissible_transaction_checks T"
using assms unfolding admissible_transaction_def by simp
have fv_r1: "fv⇩s⇩s⇩t⇩p r ⊆ fv_transaction T"
using r fv_transaction_unfold[of T] by auto
have fv_r2: "fv⇩s⇩s⇩t⇩p r ∩ set (transaction_fresh T) = {}"
using r T_valid unfolding wellformed_transaction_def by fastforce
have "(is_InSet r ∧ the_check r = Check) ∨
(is_Equality r ∧ the_check r = Check) ∨
is_NegChecks r"
using r adm_checks unfolding admissible_transaction_checks_def by fast
thus ?C'
proof (elim disjE conjE)
assume *: "is_InSet r" "the_check r = Check"
hence **: "is_Var (the_elem_term r)" "is_Fun (the_set_term r)"
"is_Set (the_Fun (the_set_term r))" "args (the_set_term r) = []"
"fst (the_Var (the_elem_term r)) = TAtom Value"
using r adm_checks unfolding admissible_transaction_checks_def is_Fun_Set_def
by fast+
obtain rt rs where r': "r = ⟨rt in rs⟩" using * by (cases r) auto
obtain x where x: "rt = Var x" "fst x = TAtom Value" using **(1,5) r' by auto
obtain f S where fS: "rs = Fun f S" using **(2) r' by auto
obtain s where s: "f = Set s" using **(3) fS r' by (cases f) auto
hence S: "S = []" using **(4) fS r' by auto
show ?C' using r' x fS s S fv_r1 fv_r2 by simp
next
assume *: "is_NegChecks r"
hence **: "bvars⇩s⇩s⇩t⇩p r = []"
"(the_eqs r = [] ∧ length (the_ins r) = 1) ∨
(the_ins r = [] ∧ length (the_eqs r) = 1)"
using r adm_checks unfolding admissible_transaction_checks_def by fast+
show ?C' using **(2)
proof (elim disjE conjE)
assume ***: "the_eqs r = []" "length (the_ins r) = 1"
then obtain t s where ts: "the_ins r = [(t,s)]" by (cases "the_ins r") auto
hence "hd (the_ins r) = (t,s)" by simp
hence ****: "is_Var (fst (t,s))" "is_Fun (snd (t,s))"
"is_Set (the_Fun (snd (t,s)))" "args (snd (t,s)) = []"
"fst (the_Var (fst (t,s))) = TAtom Value"
using r adm_checks * ***(1) unfolding admissible_transaction_checks_def is_Fun_Set_def
by metis+
obtain x where x: "t = Var x" "fst x = TAtom Value" using ts ****(1,5) by (cases t) simp_all
obtain f S where fS: "s = Fun f S" using ts ****(2) by (cases s) simp_all
obtain ss where ss: "f = Set ss" using fS ****(3) by (cases f) simp_all
have S: "S = []" using ts fS ss ****(4) by simp
show ?C' using ts x fS ss S *** **(1) * fv_r1 fv_r2 by (cases r) auto
next
assume ***: "the_ins r = []" "length (the_eqs r) = 1"
then obtain t s where "the_eqs r = [(t,s)]" by (cases "the_eqs r") auto
thus ?C' using *** **(1) * by (cases r) auto
qed
qed (auto simp add: is_Equality_def the_check_def)
qed
show "?D ⟹ ?D'"
proof -
assume r: ?D
have adm_upds: "admissible_transaction_updates T"
using assms unfolding admissible_transaction_def by simp
have *: "is_Update r" "is_Var (the_elem_term r)" "is_Fun (the_set_term r)"
"is_Set (the_Fun (the_set_term r))" "args (the_set_term r) = []"
"fst (the_Var (the_elem_term r)) = TAtom Value"
using r adm_upds unfolding admissible_transaction_updates_def is_Fun_Set_def by fast+
obtain t s where ts: "r = insert⟨t,s⟩ ∨ r = delete⟨t,s⟩" using *(1) by (cases r) auto
obtain x where x: "t = Var x" "fst x = TAtom Value" using ts *(2,6) by (cases t) auto
obtain f T where fT: "s = Fun f T" using ts *(3) by (cases s) auto
obtain ss where ss: "f = Set ss" using ts fT *(4) by (cases f) fastforce+
have T: "T = []" using ts fT *(5) ss by (cases T) auto
show ?D'
using ts x fT ss T by blast
qed
qed
lemma transaction_Value_vars_are_fv:
assumes "admissible_transaction T"
and "x ∈ vars_transaction T"
and "Γ⇩v x = TAtom Value"
shows "x ∈ fv_transaction T"
using assms Γ⇩v_TAtom''(2)[of x] vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_strand T)"]
unfolding admissible_transaction_def by fast
lemma protocol_transaction_vars_TAtom_typed:
assumes P: "admissible_transaction T"
shows "∀x ∈ vars_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
and "∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
and "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
proof -
have P': "wellformed_transaction T"
using P unfolding admissible_transaction_def by fast
show "∀x ∈ vars_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
using P Γ⇩v_TAtom''
unfolding admissible_transaction_def is_Var_def prot_atom.is_Atom_def the_Var_def
by fastforce
thus "∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
using vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t by fast
have "list_all (λx. fst x = Var Value) (transaction_fresh T)"
using P Γ⇩v_TAtom'' unfolding admissible_transaction_def by fast
thus "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
using Γ⇩v_TAtom''(2) unfolding list_all_iff by fast
qed
lemma protocol_transactions_no_pubconsts:
assumes "admissible_transaction T"
shows "Fun (Val (n,True)) S ∉ subterms⇩s⇩e⇩t (trms_transaction T)"
using assms transactions_have_no_Value_consts(1)
by fast
lemma protocol_transactions_no_abss:
assumes "admissible_transaction T"
shows "Fun (Abs n) S ∉ subterms⇩s⇩e⇩t (trms_transaction T)"
using assms transactions_have_no_Value_consts(2)
by fast
lemma admissible_transaction_strand_sem_fv_ineq:
assumes T_adm: "admissible_transaction T"
and ℐ: "strand_sem_stateful IK DB (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ℐ"
and x: "x ∈ fv_transaction T - set (transaction_fresh T)"
and y: "y ∈ fv_transaction T - set (transaction_fresh T)"
and x_not_y: "x ≠ y"
shows "θ x ⋅ ℐ ≠ θ y ⋅ ℐ"
proof -
have "⟨Var x != Var y⟩ ∈ set (unlabel (transaction_checks T)) ∨
⟨Var y != Var x⟩ ∈ set (unlabel (transaction_checks T))"
using x y x_not_y T_adm unfolding admissible_transaction_def by auto
hence "⟨Var x != Var y⟩ ∈ set (unlabel (transaction_strand T)) ∨
⟨Var y != Var x⟩ ∈ set (unlabel (transaction_strand T))"
unfolding transaction_strand_def unlabel_def by auto
hence "⟨θ x != θ y⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ∨
⟨θ y != θ x⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)))"
using stateful_strand_step_subst_inI(8)[of _ _ "unlabel (transaction_strand T)" θ]
subst_lsst_unlabel[of "transaction_strand T" θ]
dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(7)[of "[]" _ "[]"]
by force
then obtain B where B:
"prefix (B@[⟨θ x != θ y⟩]) (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) ∨
prefix (B@[⟨θ y != θ x⟩]) (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)))"
unfolding prefix_def
by (metis (no_types, hide_lams) append.assoc append_Cons append_Nil split_list)
thus ?thesis
using ℐ strand_sem_append_stateful[of IK DB _ _ ℐ]
stateful_strand_sem_NegChecks_no_bvars(2)
unfolding prefix_def
by metis
qed
lemma admissible_transactions_wf⇩t⇩r⇩m⇩s:
assumes "admissible_transaction T"
shows "wf⇩t⇩r⇩m⇩s (trms_transaction T)"
by (metis wf⇩t⇩r⇩m⇩s_code assms admissible_transaction_def admissible_transaction_terms_def)
lemma admissible_transaction_no_Ana_Attack:
assumes "admissible_transaction_terms T"
and "t ∈ subterms⇩s⇩e⇩t (trms_transaction T)"
shows "attack⟨n⟩ ∉ set (snd (Ana t))"
proof -
obtain r where r: "r ∈ set (unlabel (transaction_strand T))" "t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p r)"
using assms(2) by force
obtain K M where t: "Ana t = (K, M)"
by (metis surj_pair)
show ?thesis
proof
assume n: "attack⟨n⟩ ∈ set (snd (Ana t))"
hence "attack⟨n⟩ ∈ set M" using t by simp
hence n': "attack⟨n⟩ ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p r)"
using Ana_subterm[OF t] r(2) subterms_subset by fast
hence "∃f ∈ ⋃(funs_term ` trms⇩s⇩s⇩t⇩p r). is_Attack f"
using funs_term_Fun_subterm' unfolding is_Attack_def by fast
hence "is_Send r" "is_Fun (the_msg r)" "is_Attack (the_Fun (the_msg r))" "args (the_msg r) = []"
using assms(1) r(1) unfolding admissible_transaction_terms_def by metis+
hence "t = attack⟨n⟩"
using n' r(2) unfolding is_Send_def is_Attack_def by auto
thus False using n by fastforce
qed
qed
lemma admissible_transaction_occurs_fv_types:
assumes "admissible_transaction T"
and "x ∈ vars_transaction T"
shows "∃a. Γ (Var x) = TAtom a ∧ Γ (Var x) ≠ TAtom OccursSecType"
proof -
have "is_Var (fst x)" "the_Var (fst x) = Value"
using assms unfolding admissible_transaction_def by blast+
thus ?thesis using Γ⇩v_TAtom''(2)[of x] by force
qed
lemma admissible_transaction_Value_vars:
assumes T: "admissible_transaction T"
and x: "x ∈ fv_transaction T"
shows "Γ⇩v x = TAtom Value"
proof -
have "x ∈ vars_transaction T"
using x vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_strand T)"]
by blast
hence "is_Var (fst x)" "the_Var (fst x) = Value"
using T assms unfolding admissible_transaction_def list_all_iff by fast+
thus "Γ⇩v x = TAtom Value" using Γ⇩v_TAtom''(2)[of x] by force
qed
subsection ‹Lemmata: Renaming and Fresh Substitutions›
lemma transaction_renaming_subst_is_renaming:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "∃m. α (τ,n) = Var (τ,n+Suc m)"
using assms by (auto simp add: transaction_renaming_subst_def var_rename_def)
lemma transaction_renaming_subst_is_renaming':
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "∃y. α x = Var y"
using assms by (auto simp add: transaction_renaming_subst_def var_rename_def)
lemma transaction_renaming_subst_vars_disj:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "fv⇩s⇩e⇩t (α ` (⋃(vars_transaction ` set P))) ∩ (⋃(vars_transaction ` set P)) = {}" (is ?A)
and "fv⇩s⇩e⇩t (α ` vars⇩l⇩s⇩s⇩t A) ∩ vars⇩l⇩s⇩s⇩t A = {}" (is ?B)
and "T ∈ set P ⟹ vars_transaction T ∩ range_vars α = {}" (is "T ∈ set P ⟹ ?C1")
and "T ∈ set P ⟹ bvars_transaction T ∩ range_vars α = {}" (is "T ∈ set P ⟹ ?C2")
and "T ∈ set P ⟹ fv_transaction T ∩ range_vars α = {}" (is "T ∈ set P ⟹ ?C3")
and "vars⇩l⇩s⇩s⇩t A ∩ range_vars α = {}" (is ?D1)
and "bvars⇩l⇩s⇩s⇩t A ∩ range_vars α = {}" (is ?D2)
and "fv⇩l⇩s⇩s⇩t A ∩ range_vars α = {}" (is ?D3)
proof -
define X where "X ≡ ⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t A"
have 1: "finite X" by (simp add: X_def)
obtain n where n: "n ≥ max_var_set X" "α = var_rename n"
using assms unfolding transaction_renaming_subst_def X_def by moura
hence 2: "∀x ∈ X. snd x < Suc n"
using less_Suc_max_var_set[OF _ 1] unfolding var_rename_def by fastforce
have 3: "x ∉ fv⇩s⇩e⇩t (α ` X)" "fv (α x) ∩ X = {}" "x ∉ range_vars α" when x: "x ∈ X" for x
using 2 x n unfolding var_rename_def by force+
show ?A ?B using 3(1,2) unfolding X_def by auto
show ?C1 when T: "T ∈ set P" using T 3(3) unfolding X_def by blast
thus ?C2 ?C3 when T: "T ∈ set P"
using T by (simp_all add: disjoint_iff_not_equal vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t)
show ?D1 using 3(3) unfolding X_def by auto
thus ?D2 ?D3 by (simp_all add: disjoint_iff_not_equal vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t)
qed
lemma transaction_renaming_subst_wt:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "wt⇩s⇩u⇩b⇩s⇩t α"
proof -
{ fix x::"('fun,'atom,'sets) prot_var"
obtain τ n where x: "x = (τ,n)" by moura
then obtain m where m: "α x = Var (τ,m)"
using assms transaction_renaming_subst_is_renaming by moura
hence "Γ (α x) = Γ⇩v x" using x by (simp add: Γ⇩v_def)
} thus ?thesis by (simp add: wt⇩s⇩u⇩b⇩s⇩t_def)
qed
lemma transaction_renaming_subst_is_wf_trm:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "wf⇩t⇩r⇩m (α v)"
proof -
obtain τ n where "v = (τ, n)" by moura
then obtain m where "α v = Var (τ, n + Suc m)"
using transaction_renaming_subst_is_renaming[OF assms]
by moura
thus ?thesis by (metis wf_trm_Var)
qed
lemma transaction_renaming_subst_range_wf_trms:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "wf⇩t⇩r⇩m⇩s (subst_range α)"
by (metis transaction_renaming_subst_is_wf_trm[OF assms] wf_trm_subst_range_iff)
lemma transaction_renaming_subst_range_notin_vars:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P 𝒜"
shows "∃y. α x = Var y ∧ y ∉ ⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t 𝒜"
proof -
obtain τ n where x: "x = (τ,n)" by (metis surj_pair)
define y where "y ≡ λm. (τ,n+Suc m)"
have "∃m ≥ max_var_set (⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t 𝒜). α x = Var (y m)"
using assms x by (auto simp add: y_def transaction_renaming_subst_def var_rename_def)
moreover have "finite (⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t 𝒜)" by auto
ultimately show ?thesis using x unfolding y_def by force
qed
lemma transaction_renaming_subst_var_obtain:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes x: "x ∈ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t α)"
and α: "transaction_renaming_subst α P 𝒜"
shows "∃y. α y = Var x"
proof -
obtain y where y: "y ∈ fv⇩s⇩s⇩t S" "x ∈ fv (α y)" using fv⇩s⇩s⇩t_subst_obtain_var[OF x] by moura
thus ?thesis using transaction_renaming_subst_is_renaming'[OF α, of y] by fastforce
qed
lemma transaction_fresh_subst_is_wf_trm:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T A"
shows "wf⇩t⇩r⇩m (σ v)"
proof (cases "v ∈ subst_domain σ")
case True
then obtain n where "σ v = Fun (Val n) []"
using assms unfolding transaction_fresh_subst_def
by moura
thus ?thesis by auto
qed auto
lemma transaction_fresh_subst_wt:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T A"
and "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
shows "wt⇩s⇩u⇩b⇩s⇩t σ"
proof -
have 1: "subst_domain σ = set (transaction_fresh T)"
and 2: "∀t ∈ subst_range σ. ∃n. t = Fun (Val n) []"
using assms(1) unfolding transaction_fresh_subst_def by metis+
{ fix x::"('fun,'atom,'sets) prot_var"
have "Γ (Var x) = Γ (σ x)" using assms(2) 1 2 by (cases "x ∈ subst_domain σ") force+
} thus ?thesis by (simp add: wt⇩s⇩u⇩b⇩s⇩t_def)
qed
lemma transaction_fresh_subst_domain:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
shows "subst_domain σ = set (transaction_fresh T)"
using assms unfolding transaction_fresh_subst_def by fast
lemma transaction_fresh_subst_range_wf_trms:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
shows "wf⇩t⇩r⇩m⇩s (subst_range σ)"
by (metis transaction_fresh_subst_is_wf_trm[OF assms] wf_trm_subst_range_iff)
lemma transaction_fresh_subst_range_fresh:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
shows "∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
and "∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_strand T))"
using assms unfolding transaction_fresh_subst_def by meson+
lemma transaction_fresh_subst_sends_to_val:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
and "y ∈ set (transaction_fresh T)"
obtains n where "σ y = Fun (Val n) []" "Fun (Val n) [] ∈ subst_range σ"
proof -
have "σ y ∈ subst_range σ" using assms unfolding transaction_fresh_subst_def by simp
thus ?thesis
using assms that unfolding transaction_fresh_subst_def
by fastforce
qed
lemma transaction_fresh_subst_sends_to_val':
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
and "y ∈ set (transaction_fresh T)"
obtains n where "(σ ∘⇩s α) y ⋅ ℐ = Fun (Val n) []" "Fun (Val n) [] ∈ subst_range σ"
proof -
obtain n where "σ y = Fun (Val n) []" "Fun (Val n) [] ∈ subst_range σ"
using transaction_fresh_subst_sends_to_val[OF assms] by moura
thus ?thesis using that by (fastforce simp add: subst_compose_def)
qed
lemma transaction_fresh_subst_grounds_domain:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
and "y ∈ set (transaction_fresh T)"
shows "fv (σ y) = {}"
proof -
obtain n where "σ y = Fun (Val n) []"
using transaction_fresh_subst_sends_to_val[OF assms]
by moura
thus ?thesis by simp
qed
lemma transaction_fresh_subst_transaction_renaming_subst_range:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜" "transaction_renaming_subst α P 𝒜"
shows "x ∈ set (transaction_fresh T) ⟹ ∃n. (σ ∘⇩s α) x = Fun (Val (n,False)) []"
and "x ∉ set (transaction_fresh T) ⟹ ∃y. (σ ∘⇩s α) x = Var y"
proof -
assume "x ∈ set (transaction_fresh T)"
then obtain n where "σ x = Fun (Val (n,False)) []"
using assms(1) unfolding transaction_fresh_subst_def by fastforce
thus "∃n. (σ ∘⇩s α) x = Fun (Val (n,False)) []" using subst_compose[of σ α x] by simp
next
assume "x ∉ set (transaction_fresh T)"
hence "σ x = Var x"
using assms(1) unfolding transaction_fresh_subst_def by fastforce
thus "∃y. (σ ∘⇩s α) x = Var y"
using transaction_renaming_subst_is_renaming[OF assms(2)] subst_compose[of σ α x]
by (cases x) force
qed
lemma transaction_fresh_subst_transaction_renaming_subst_range':
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜" "transaction_renaming_subst α P 𝒜"
and "t ∈ subst_range (σ ∘⇩s α)"
shows "(∃n. t = Fun (Val (n,False)) []) ∨ (∃x. t = Var x)"
proof -
obtain x where "x ∈ subst_domain (σ ∘⇩s α)" "(σ ∘⇩s α) x = t"
using assms(3) by auto
thus ?thesis
using transaction_fresh_subst_transaction_renaming_subst_range[OF assms(1,2), of x]
by auto
qed
lemma transaction_fresh_subst_transaction_renaming_subst_range'':
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes s: "transaction_fresh_subst σ T 𝒜" "transaction_renaming_subst α P 𝒜"
and y: "y ∈ fv ((σ ∘⇩s α) x)"
shows "σ x = Var x"
and "α x = Var y"
and "(σ ∘⇩s α) x = Var y"
proof -
have "∃z. z ∈ fv (σ x)"
using y subst_compose_fv'
by fast
hence x: "x ∉ subst_domain σ"
using y transaction_fresh_subst_domain[OF s(1)]
transaction_fresh_subst_grounds_domain[OF s(1), of x]
by blast
thus "σ x = Var x" by blast
thus "α x = Var y" "(σ ∘⇩s α) x = Var y"
using y transaction_renaming_subst_is_renaming'[OF s(2), of x]
unfolding subst_compose_def by fastforce+
qed
lemma transaction_fresh_subst_transaction_renaming_subst_vars_subset:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
shows "⋃(fv_transaction ` set P) ⊆ subst_domain (σ ∘⇩s α)" (is ?A)
and "fv⇩l⇩s⇩s⇩t 𝒜 ⊆ subst_domain (σ ∘⇩s α)" (is ?B)
and "T' ∈ set P ⟹ fv_transaction T' ⊆ subst_domain (σ ∘⇩s α)" (is "T' ∈ set P ⟹ ?C")
and "T' ∈ set P ⟹ fv⇩l⇩s⇩s⇩t (transaction_strand T' ⋅⇩l⇩s⇩s⇩t (σ ∘⇩s α)) ⊆ range_vars (σ ∘⇩s α)"
(is "T' ∈ set P ⟹ ?D")
proof -
have *: "x ∈ subst_domain (σ ∘⇩s α)" for x
proof (cases "x ∈ subst_domain σ")
case True
hence "x ∉ {x. ∃y. σ x = Var y ∧ α y = Var x}"
using transaction_fresh_subst_domain[OF σ]
transaction_fresh_subst_grounds_domain[OF σ, of x]
by auto
thus ?thesis using subst_domain_subst_compose[of σ α] by blast
next
case False
hence "(σ ∘⇩s α) x = α x" unfolding subst_compose_def by fastforce
moreover have "α x ≠ Var x"
using transaction_renaming_subst_is_renaming[OF α, of "fst x" "snd x"] by (cases x) auto
ultimately show ?thesis by fastforce
qed
show ?A ?B using * by blast+
show ?C when T: "T' ∈ set P" using T * by blast
hence "fv⇩s⇩s⇩t (unlabel (transaction_strand T') ⋅⇩s⇩s⇩t σ ∘⇩s α) ⊆ range_vars (σ ∘⇩s α)"
when T: "T' ∈ set P"
using T fv⇩s⇩s⇩t_subst_subset_range_vars_if_subset_domain by blast
thus ?D when T: "T' ∈ set P" by (metis T unlabel_subst)
qed
lemma transaction_fresh_subst_transaction_renaming_subst_vars_disj:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
shows "fv⇩s⇩e⇩t ((σ ∘⇩s α) ` (⋃(vars_transaction ` set P))) ∩ (⋃(vars_transaction ` set P)) = {}"
(is ?A)
and "x ∈ ⋃(vars_transaction ` set P) ⟹ fv ((σ ∘⇩s α) x) ∩ (⋃(vars_transaction ` set P)) = {}"
(is "?B' ⟹ ?B")
and "T' ∈ set P ⟹ vars_transaction T' ∩ range_vars (σ ∘⇩s α) = {}" (is "T' ∈ set P ⟹ ?C1")
and "T' ∈ set P ⟹ bvars_transaction T' ∩ range_vars (σ ∘⇩s α) = {}" (is "T' ∈ set P ⟹ ?C2")
and "T' ∈ set P ⟹ fv_transaction T' ∩ range_vars (σ ∘⇩s α) = {}" (is "T' ∈ set P ⟹ ?C3")
and "vars⇩l⇩s⇩s⇩t 𝒜 ∩ range_vars (σ ∘⇩s α) = {}" (is ?D1)
and "bvars⇩l⇩s⇩s⇩t 𝒜 ∩ range_vars (σ ∘⇩s α) = {}" (is ?D2)
and "fv⇩l⇩s⇩s⇩t 𝒜 ∩ range_vars (σ ∘⇩s α) = {}" (is ?D3)
proof -
note 0 = transaction_renaming_subst_vars_disj[OF α]
show ?A
proof (cases "fv⇩s⇩e⇩t ((σ ∘⇩s α) ` (⋃(vars_transaction ` set P))) = {}")
case False
hence "∀x ∈ (⋃(vars_transaction ` set P)). (σ ∘⇩s α) x = α x ∨ fv ((σ ∘⇩s α) x) = {}"
using transaction_fresh_subst_transaction_renaming_subst_range''[OF σ α] by auto
thus ?thesis using 0(1) by force
qed blast
thus "?B' ⟹ ?B" by auto
have 1: "range_vars (σ ∘⇩s α) ⊆ range_vars α"
using range_vars_subst_compose_subset[of σ α]
transaction_fresh_subst_domain[OF σ]
transaction_fresh_subst_grounds_domain[OF σ]
by force
show ?C1 ?C2 ?C3 when T: "T' ∈ set P" using T 1 0(3,4,5)[of T'] by blast+
show ?D1 ?D2 ?D3 using 1 0(6,7,8) by blast+
qed
lemma transaction_fresh_subst_transaction_renaming_subst_trms:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜" "transaction_renaming_subst α P 𝒜"
and "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain σ = {}"
and "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain α = {}"
shows "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t (σ ∘⇩s α))) = subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S) ⋅⇩s⇩e⇩t (σ ∘⇩s α)"
proof -
have 1: "∀x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S). (∃f. (σ ∘⇩s α) x = Fun f []) ∨ (∃y. (σ ∘⇩s α) x = Var y)"
using transaction_fresh_subst_transaction_renaming_subst_range[OF assms(1,2)] by blast
have 2: "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain (σ ∘⇩s α) = {}"
using assms(3,4) subst_domain_compose[of σ α] by blast
show ?thesis using subterms_subst_lsst[OF 1 2] by simp
qed
lemma transaction_fresh_subst_transaction_renaming_wt:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜" "transaction_renaming_subst α P 𝒜"
and "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
shows "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using transaction_renaming_subst_wt[OF assms(2)]
transaction_fresh_subst_wt[OF assms(1,3)]
by (metis wt_subst_compose)
lemma transaction_fresh_subst_transaction_renaming_fv:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes σ: "transaction_fresh_subst σ T A"
and α: "transaction_renaming_subst α P A"
and x: "x ∈ fv⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
shows "∃y ∈ fv_transaction T - set (transaction_fresh T). (σ ∘⇩s α) y = Var x"
proof -
have "x ∈ fv⇩s⇩s⇩t (unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α)"
using x fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by argo
then obtain y where "y ∈ fv_transaction T" "x ∈ fv ((σ ∘⇩s α) y)"
by (metis fv⇩s⇩s⇩t_subst_obtain_var)
thus ?thesis
using transaction_fresh_subst_transaction_renaming_subst_range[OF σ α, of y]
by (cases "y ∈ set (transaction_fresh T)") force+
qed
lemma transaction_fresh_subst_transaction_renaming_subst_occurs_fact_send_receive:
fixes t::"('fun,'atom,'sets) prot_term"
assumes σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and T: "wellformed_transaction T"
shows "send⟨occurs t⟩ ∈ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))
⟹ ∃s. send⟨occurs s⟩ ∈ set (unlabel (transaction_send T)) ∧ t = s ⋅ σ ∘⇩s α"
(is "?A ⟹ ?A'")
and "receive⟨occurs t⟩ ∈ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))
⟹ ∃s. receive⟨occurs s⟩ ∈ set (unlabel (transaction_receive T)) ∧ t = s ⋅ σ ∘⇩s α"
(is "?B ⟹ ?B'")
proof -
assume ?A
then obtain s where s: "send⟨s⟩ ∈ set (unlabel (transaction_strand T))" "occurs t = s ⋅ σ ∘⇩s α"
using stateful_strand_step_subst_inv_cases(1)[
of "occurs t" "unlabel (transaction_strand T)" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by auto
note 0 = s(2) transaction_fresh_subst_transaction_renaming_subst_range[OF σ α]
have "∃u. s = occurs u"
proof (cases s)
case (Var x)
hence "(∃n. s ⋅ σ ∘⇩s α = Fun (Val (n, False)) []) ∨ (∃y. s ⋅ σ ∘⇩s α = Var y)"
using 0(2,3)[of x] by (auto simp del: subst_subst_compose)
thus ?thesis
using 0(1) by simp
next
case (Fun f T)
hence 1: "f = OccursFact" "length T = 2" "T ! 0 ⋅ σ ∘⇩s α = Fun OccursSec []" "T ! 1 ⋅ σ ∘⇩s α = t"
using 0(1) by auto
have "T ! 0 = Fun OccursSec []"
proof (cases "T ! 0")
case (Var x) thus ?thesis using 0(2,3)[of x] 1(3) by (auto simp del: subst_subst_compose)
qed (use 1(3) in simp)
thus ?thesis using Fun 1 0(1) by (auto simp del: subst_subst_compose)
qed
then obtain u where u: "s = occurs u" by moura
hence "t = u ⋅ σ ∘⇩s α" using s(2) by fastforce
thus ?A' using s u wellformed_transaction_strand_unlabel_memberD(8)[OF T] by metis
next
assume ?B
then obtain s where s: "receive⟨s⟩ ∈ set (unlabel (transaction_strand T))" "occurs t = s ⋅ σ ∘⇩s α"
using stateful_strand_step_subst_inv_cases(2)[
of "occurs t" "unlabel (transaction_strand T)" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by auto
note 0 = s(2) transaction_fresh_subst_transaction_renaming_subst_range[OF σ α]
have "∃u. s = occurs u"
proof (cases s)
case (Var x)
hence "(∃n. s ⋅ σ ∘⇩s α = Fun (Val (n, False)) []) ∨ (∃y. s ⋅ σ ∘⇩s α = Var y)"
using 0(2,3)[of x] by (auto simp del: subst_subst_compose)
thus ?thesis
using 0(1) by simp
next
case (Fun f T)
hence 1: "f = OccursFact" "length T = 2" "T ! 0 ⋅ σ ∘⇩s α = Fun OccursSec []" "T ! 1 ⋅ σ ∘⇩s α = t"
using 0(1) by auto
have "T ! 0 = Fun OccursSec []"
proof (cases "T ! 0")
case (Var x) thus ?thesis using 0(2,3)[of x] 1(3) by (auto simp del: subst_subst_compose)
qed (use 1(3) in simp)
thus ?thesis using Fun 1 0(1) by (auto simp del: subst_subst_compose)
qed
then obtain u where u: "s = occurs u" by moura
hence "t = u ⋅ σ ∘⇩s α" using s(2) by fastforce
thus ?B' using s u wellformed_transaction_strand_unlabel_memberD(1)[OF T] by metis
qed
lemma transaction_fresh_subst_proj:
assumes "transaction_fresh_subst σ T A"
shows "transaction_fresh_subst σ (transaction_proj n T) (proj n A)"
using assms transaction_proj_fresh_eq[of n T]
contra_subsetD[OF subterms⇩s⇩e⇩t_mono[OF transaction_proj_trms_subset[of n T]]]
contra_subsetD[OF subterms⇩s⇩e⇩t_mono[OF trms⇩s⇩s⇩t_proj_subset(1)[of n A]]]
unfolding transaction_fresh_subst_def by metis
lemma transaction_renaming_subst_proj:
assumes "transaction_renaming_subst α P A"
shows "transaction_renaming_subst α (map (transaction_proj n) P) (proj n A)"
proof -
let ?X = "λP A. ⋃(vars_transaction ` set P) ∪ vars⇩l⇩s⇩s⇩t A"
define Y where "Y ≡ ?X (map (transaction_proj n) P) (proj n A)"
define Z where "Z ≡ ?X P A"
have "Y ⊆ Z"
using sst_vars_proj_subset(3)[of n A] transaction_proj_vars_subset[of n]
unfolding Y_def Z_def by fastforce
hence "insert 0 (snd ` Y) ⊆ insert 0 (snd ` Z)" by blast
moreover have "finite (insert 0 (snd ` Z))" "finite (insert 0 (snd ` Y))"
unfolding Y_def Z_def by auto
ultimately have 0: "max_var_set Y ≤ max_var_set Z" using Max_mono by blast
have "∃n≥max_var_set Z. α = var_rename n"
using assms unfolding transaction_renaming_subst_def Z_def by blast
hence "∃n≥max_var_set Y. α = var_rename n" using 0 le_trans by fast
thus ?thesis unfolding transaction_renaming_subst_def Y_def by blast
qed
lemma protocol_transaction_wf_subst:
fixes σ α::"('fun,'atom,'sets) prot_subst"
assumes T: "wf'⇩s⇩s⇩t (set (transaction_fresh T)) (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
shows "wf'⇩s⇩s⇩t {} (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
proof -
have 0: "range_vars σ ∩ bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T)) = {}"
"ground (σ ` set (transaction_fresh T))" "ground (α ` {})"
using transaction_fresh_subst_domain[OF σ] transaction_fresh_subst_grounds_domain[OF σ]
by fastforce+
have "wf'⇩s⇩s⇩t {} ((unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)) ⋅⇩s⇩s⇩t σ) ⋅⇩s⇩s⇩t α)"
by (metis wf⇩s⇩s⇩t_subst_apply[OF wf⇩s⇩s⇩t_subst_apply[OF T]] 0(2,3))
thus ?thesis
by (metis dual⇩l⇩s⇩s⇩t_subst unlabel_subst labeled_stateful_strand_subst_comp[OF 0(1)])
qed
subsection ‹Lemmata: Reachable Constraints›
lemma reachable_constraints_wf⇩t⇩r⇩m⇩s:
assumes "∀T ∈ set P. wf⇩t⇩r⇩m⇩s (trms_transaction T)"
and "𝒜 ∈ reachable_constraints P"
shows "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
using assms(2)
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
have "wf⇩t⇩r⇩m⇩s (trms_transaction T)"
using assms(1) step.hyps(2) by blast
moreover have "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using wf_trms_subst_compose[of σ α]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
by fastforce
ultimately have "wf⇩t⇩r⇩m⇩s (trms_transaction T ⋅⇩s⇩e⇩t σ ∘⇩s α)" by (metis wf_trms_subst)
hence "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using wf⇩t⇩r⇩m⇩s_trms⇩s⇩s⇩t_subst unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"] by metis
hence "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
using trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq by blast
thus ?case using step.IH unlabel_append[of 𝒜] trms⇩s⇩s⇩t_append[of "unlabel 𝒜"] by auto
qed simp
lemma reachable_constraints_TAtom_types:
assumes "𝒜 ∈ reachable_constraints P"
and "∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
shows "Γ⇩v ` fv⇩l⇩s⇩s⇩t 𝒜 ⊆ (⋃T ∈ set P. Γ⇩v ` fv_transaction T)" (is "?A 𝒜")
and "Γ⇩v ` bvars⇩l⇩s⇩s⇩t 𝒜 ⊆ (⋃T ∈ set P. Γ⇩v ` bvars_transaction T)" (is "?B 𝒜")
and "Γ⇩v ` vars⇩l⇩s⇩s⇩t 𝒜 ⊆ (⋃T ∈ set P. Γ⇩v ` vars_transaction T)" (is "?C 𝒜")
using assms(1)
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have 2: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using transaction_renaming_subst_wt[OF step.hyps(4)]
transaction_fresh_subst_wt[OF step.hyps(3)]
by (metis step.hyps(2) assms(2) wt_subst_compose)
have 3: "∀t ∈ subst_range (σ ∘⇩s α). fv t = {} ∨ (∃x. t = Var x)"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
by fastforce
have "fv⇩l⇩s⇩s⇩t T' = fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
"bvars⇩l⇩s⇩s⇩t T' = bvars⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
"vars⇩l⇩s⇩s⇩t T' = vars⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
unfolding T'_def
by (metis fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq,
metis bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq,
metis vars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq)
hence "Γ ` Var ` fv⇩l⇩s⇩s⇩t T' ⊆ Γ ` Var ` fv_transaction T"
"Γ ` Var ` bvars⇩l⇩s⇩s⇩t T' = Γ ` Var ` bvars_transaction T"
"Γ ` Var ` vars⇩l⇩s⇩s⇩t T' ⊆ Γ ` Var ` vars_transaction T"
using wt_subst_lsst_vars_type_subset[OF 2 3, of "transaction_strand T"]
by argo+
hence "Γ⇩v ` fv⇩l⇩s⇩s⇩t T' ⊆ Γ⇩v ` fv_transaction T"
"Γ⇩v ` bvars⇩l⇩s⇩s⇩t T' = Γ⇩v ` bvars_transaction T"
"Γ⇩v ` vars⇩l⇩s⇩s⇩t T' ⊆ Γ⇩v ` vars_transaction T"
by (metis Γ⇩v_Var_image)+
hence 4: "Γ⇩v ` fv⇩l⇩s⇩s⇩t T' ⊆ (⋃T ∈ set P. Γ⇩v ` fv_transaction T)"
"Γ⇩v ` bvars⇩l⇩s⇩s⇩t T' ⊆ (⋃T ∈ set P. Γ⇩v ` bvars_transaction T)"
"Γ⇩v ` vars⇩l⇩s⇩s⇩t T' ⊆ (⋃T ∈ set P. Γ⇩v ` vars_transaction T)"
using step.hyps(2) by fast+
have 5: "Γ⇩v ` fv⇩l⇩s⇩s⇩t (𝒜 @ T') = (Γ⇩v ` fv⇩l⇩s⇩s⇩t 𝒜) ∪ (Γ⇩v ` fv⇩l⇩s⇩s⇩t T')"
"Γ⇩v ` bvars⇩l⇩s⇩s⇩t (𝒜 @ T') = (Γ⇩v ` bvars⇩l⇩s⇩s⇩t 𝒜) ∪ (Γ⇩v ` bvars⇩l⇩s⇩s⇩t T')"
"Γ⇩v ` vars⇩l⇩s⇩s⇩t (𝒜 @ T') = (Γ⇩v ` vars⇩l⇩s⇩s⇩t 𝒜) ∪ (Γ⇩v ` vars⇩l⇩s⇩s⇩t T')"
using unlabel_append[of 𝒜 T']
fv⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"]
bvars⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"]
vars⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"]
by auto
{ case 1 thus ?case
using step.IH(1) 4(1) 5(1)
unfolding T'_def by (simp del: subst_subst_compose fv⇩s⇩s⇩t_def)
}
{ case 2 thus ?case
using step.IH(2) 4(2) 5(2)
unfolding T'_def by (simp del: subst_subst_compose bvars⇩s⇩s⇩t_def)
}
{ case 3 thus ?case
using step.IH(3) 4(3) 5(3)
unfolding T'_def by (simp del: subst_subst_compose)
}
qed simp_all
lemma reachable_constraints_no_bvars:
assumes 𝒜: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. bvars⇩l⇩s⇩s⇩t (transaction_strand T) = {}"
shows "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using assms proof (induction)
case init
then show ?case
unfolding unlabel_def by auto
next
case (step 𝒜 T σ α)
then have "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
by metis
moreover
have "bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) = {}"
using step by (metis bvars⇩l⇩s⇩s⇩t_subst bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq)
ultimately
show ?case
using bvars⇩s⇩s⇩t_append unlabel_append by (metis sup_bot.left_neutral)
qed
lemma reachable_constraints_fv_bvars_disj:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and P: "∀S ∈ set P. admissible_transaction S"
shows "fv⇩l⇩s⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
proof -
let ?X = "⋃T ∈ set P. bvars_transaction T"
note 0 = transactions_fv_bvars_disj[OF P]
have 1: "bvars⇩l⇩s⇩s⇩t 𝒜 ⊆ ?X" using 𝒜_reach
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
have "bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) = bvars_transaction T"
using bvars⇩s⇩s⇩t_subst[of "unlabel (transaction_strand T)" "σ ∘⇩s α"]
bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
dual⇩l⇩s⇩s⇩t_subst[of "transaction_strand T" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by argo
hence "bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ⊆ ?X"
using step.hyps(2)
by blast
thus ?case
using step.IH bvars⇩s⇩s⇩t_append
by auto
qed (simp add: unlabel_def bvars⇩s⇩s⇩t_def)
have 2: "fv⇩l⇩s⇩s⇩t 𝒜 ∩ ?X = {}" using 𝒜_reach
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
have "x ≠ y" when x: "x ∈ ?X" and y: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)" for x y
proof -
obtain y' where y': "y' ∈ fv_transaction T" "y ∈ fv ((σ ∘⇩s α) y')"
using y unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by (metis fv⇩s⇩s⇩t_subst_obtain_var)
have "y ∉ ⋃(vars_transaction ` set P)"
using transaction_fresh_subst_transaction_renaming_subst_range''[OF step.hyps(3,4) y'(2)]
transaction_renaming_subst_range_notin_vars[OF step.hyps(4), of y']
by auto
thus ?thesis using x vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t by fast
qed
hence "fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α) ∩ ?X = {}"
by blast
thus ?case
using step.IH
fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
dual⇩l⇩s⇩s⇩t_subst[of "transaction_strand T" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
fv⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"]
unlabel_append[of 𝒜 "transaction_strand T"]
by force
qed (simp add: unlabel_def fv⇩s⇩s⇩t_def)
show ?thesis using 0 1 2 by blast
qed
lemma reachable_constraints_vars_TAtom_typed:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "x ∈ vars⇩l⇩s⇩s⇩t 𝒜"
shows "Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
proof -
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P 𝒜_reach)
have T_adm: "admissible_transaction T" when "T ∈ set P" for T
by (meson that Ball_set P)
have "∀T∈set P. ∀x∈set (transaction_fresh T). Γ⇩v x = TAtom Value"
using protocol_transaction_vars_TAtom_typed(3) P by blast
hence *: "Γ⇩v ` vars⇩l⇩s⇩s⇩t 𝒜 ⊆ (⋃T∈set P. Γ⇩v ` vars_transaction T)"
using reachable_constraints_TAtom_types[of 𝒜 P, OF 𝒜_reach] by auto
have "Γ⇩v ` vars⇩l⇩s⇩s⇩t 𝒜 ⊆ TAtom ` insert Value (range Atom)"
proof -
have "Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
when "T ∈ set P" "x ∈ vars_transaction T" for T x
using that protocol_transaction_vars_TAtom_typed(1)[of T] P
unfolding admissible_transaction_def
by blast
hence "(⋃T∈set P. Γ⇩v ` vars_transaction T) ⊆ TAtom ` insert Value (range Atom)"
using P by blast
thus "Γ⇩v ` vars⇩l⇩s⇩s⇩t 𝒜 ⊆ TAtom ` insert Value (range Atom)"
using * by auto
qed
thus ?thesis using x by auto
qed
lemma reachable_constraints_Value_vars_are_fv:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "x ∈ vars⇩l⇩s⇩s⇩t 𝒜"
and "Γ⇩v x = TAtom Value"
shows "x ∈ fv⇩l⇩s⇩s⇩t 𝒜"
proof -
have "∀T∈set P. bvars_transaction T = {}"
using P unfolding list_all_iff admissible_transaction_def by metis
hence 𝒜_no_bvars: "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using reachable_constraints_no_bvars[OF 𝒜_reach] by metis
thus ?thesis using x vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"] by blast
qed
lemma reachable_constraints_subterms_subst:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
shows "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ)) = (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)) ⋅⇩s⇩e⇩t ℐ"
proof -
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P 𝒜_reach)
from ℐ have ℐ': "welltyped_constraint_model ℐ 𝒜"
using welltyped_constraint_model_prefix by auto
have 1: "∀x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜). (∃f. ℐ x = Fun f []) ∨ (∃y. ℐ x = Var y)"
proof
fix x
assume xa: "x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
have "∃f T. ℐ x = Fun f T"
using ℐ interpretation_grounds[of ℐ "Var x"]
unfolding welltyped_constraint_model_def constraint_model_def
by (cases "ℐ x") auto
then obtain f T where fT_p: "ℐ x = Fun f T"
by auto
hence "wf⇩t⇩r⇩m (Fun f T)"
using ℐ
unfolding welltyped_constraint_model_def constraint_model_def
using wf_trm_subst_rangeD
by metis
moreover
have "x ∈ vars⇩l⇩s⇩s⇩t 𝒜"
using xa var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t[of x "unlabel 𝒜"] vars_iff_subtermeq[of x]
by auto
hence "∃a. Γ⇩v x = TAtom a"
using reachable_constraints_vars_TAtom_typed[OF 𝒜_reach P] by blast
hence "∃a. Γ (Var x) = TAtom a"
by simp
hence "∃a. Γ (Fun f T) = TAtom a"
by (metis (no_types, hide_lams) ℐ' welltyped_constraint_model_def fT_p wt⇩s⇩u⇩b⇩s⇩t_def)
ultimately show "(∃f. ℐ x = Fun f []) ∨ (∃y. ℐ x = Var y)"
using TAtom_term_cases fT_p by metis
qed
have "∀T∈set P. bvars_transaction T = {}"
using assms unfolding list_all_iff admissible_transaction_def by metis
then have "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using reachable_constraints_no_bvars assms by metis
then have 2: "bvars⇩l⇩s⇩s⇩t 𝒜 ∩ subst_domain ℐ = {}"
by auto
show ?thesis
using subterms_subst_lsst[OF _ 2] 1
by simp
qed
lemma reachable_constraints_val_funs_private:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and f: "f ∈ ⋃(funs_term ` trms⇩l⇩s⇩s⇩t 𝒜)"
shows "is_Val f ⟹ ¬public f"
and "¬is_Abs f"
proof -
have "(is_Val f ⟶ ¬public f) ∧ ¬is_Abs f" using 𝒜_reach f
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
let ?T' = "unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α"
let ?T'' = "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
have T: "admissible_transaction_terms T"
using P step.hyps(2) unfolding admissible_transaction_def by metis
show ?thesis using step
proof (cases "f ∈ ⋃(funs_term ` trms⇩l⇩s⇩s⇩t 𝒜)")
case False
then obtain t where t: "t ∈ trms⇩s⇩s⇩t ?T'" "f ∈ funs_term t"
using step.prems trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of ?T'']
trms⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel (dual⇩l⇩s⇩s⇩t ?T'')"]
unlabel_append[of 𝒜 "dual⇩l⇩s⇩s⇩t ?T''"] unlabel_subst[of "transaction_strand T"]
by fastforce
show ?thesis using trms⇩s⇩s⇩t_funs_term_cases[OF t]
proof
assume "∃u ∈ trms_transaction T. f ∈ funs_term u"
thus ?thesis using T unfolding admissible_transaction_terms_def by blast
next
assume "∃x ∈ fv_transaction T. f ∈ funs_term ((σ ∘⇩s α) x)"
then obtain x where "x ∈ fv_transaction T" "f ∈ funs_term ((σ ∘⇩s α) x)" by moura
thus ?thesis
using transaction_fresh_subst_transaction_renaming_subst_range[OF step.hyps(3,4), of x]
by (force simp del: subst_subst_compose)
qed
qed simp
qed simp
thus "is_Val f ⟹ ¬public f" "¬is_Abs f" by simp_all
qed
lemma reachable_constraints_occurs_fact_ik_case:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and occ: "occurs t ∈ ik⇩l⇩s⇩s⇩t A"
shows "∃n. t = Fun (Val (n,False)) []"
using 𝒜_reach occ
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
define θ where "θ ≡ σ ∘⇩s α"
have T: "wellformed_transaction T" "admissible_transaction_occurs_checks T"
using P step.hyps(2) unfolding list_all_iff admissible_transaction_def by blast+
show ?case
proof (cases "occurs t ∈ ik⇩l⇩s⇩s⇩t A")
case False
hence "occurs t ∈ ik⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
using step.prems unfolding θ_def by simp
hence "receive⟨occurs t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)))"
unfolding ik⇩s⇩s⇩t_def by force
hence "send⟨occurs t⟩ ∈ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(1) by blast
then obtain s where s:
"send⟨s⟩ ∈ set (unlabel (transaction_strand T))" "s ⋅ θ = occurs t"
by (metis (no_types) stateful_strand_step_subst_inv_cases(1) unlabel_subst)
note 0 = transaction_fresh_subst_transaction_renaming_subst_range[OF step.hyps(3,4)]
have 1: "send⟨s⟩ ∈ set (unlabel (transaction_send T))"
using s(1) wellformed_transaction_strand_unlabel_memberD(8)[OF T(1)] by blast
have 2: "is_Send (send⟨s⟩)"
unfolding is_Send_def by simp
have 3: "∃u. s = occurs u"
proof -
{ fix z
have "(∃n. θ z = Fun (Val (n, False)) []) ∨ (∃y. θ z = Var y)"
using 0
unfolding θ_def
by blast
hence "∄u. θ z = occurs u" "θ z ≠ Fun OccursSec []" by auto
} note * = this
obtain u u' where T: "s = Fun OccursFact [u,u']"
using *(1) s(2) by (cases s) auto
thus ?thesis using *(2) s(2) by (cases u) auto
qed
obtain x where x: "x ∈ set (transaction_fresh T)" "s = occurs (Var x)"
using T(2) 1 2 3
unfolding admissible_transaction_occurs_checks_def
by fastforce
have "t = θ x"
using s(2) x(2) by auto
thus ?thesis
using 0(1)[OF x(1)] unfolding θ_def by fast
qed (simp add: step.IH)
qed simp
lemma reachable_constraints_occurs_fact_send_ex:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "Γ⇩v x = TAtom Value" "x ∈ fv⇩l⇩s⇩s⇩t A"
shows "send⟨occurs (Var x)⟩ ∈ set (unlabel A)"
using 𝒜_reach x(2)
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
have T: "admissible_transaction_occurs_checks T"
using P step.hyps(2) unfolding list_all_iff admissible_transaction_def by blast
show ?case
proof (cases "x ∈ fv⇩l⇩s⇩s⇩t A")
case True
show ?thesis
using step.IH[OF True] unlabel_append[of A]
by auto
next
case False
then obtain y where y: "y ∈ fv_transaction T - set (transaction_fresh T)" "(σ ∘⇩s α) y = Var x"
using transaction_fresh_subst_transaction_renaming_fv[OF step.hyps(3,4), of x]
step.prems(1) fv⇩s⇩s⇩t_append[of "unlabel A"] unlabel_append[of A]
by auto
have "σ y = Var y" using y(1) step.hyps(3) unfolding transaction_fresh_subst_def by auto
hence "α y = Var x" using y(2) unfolding subst_compose_def by simp
hence y_val: "fst y = TAtom Value"
using x(1) Γ⇩v_TAtom''[of x] Γ⇩v_TAtom''[of y]
wt_subst_trm''[OF transaction_renaming_subst_wt[OF step.hyps(4)], of "Var y"]
by force
hence "receive⟨occurs (Var y)⟩ ∈ set (unlabel (transaction_receive T))"
using y(1) T unfolding admissible_transaction_occurs_checks_def by fast
hence *: "receive⟨occurs (Var y)⟩ ∈ set (unlabel (transaction_strand T))"
using transaction_strand_subsets(6) by blast
have "receive⟨occurs (Var x)⟩ ∈ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using y(2) unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
stateful_strand_step_subst_inI(2)[OF *, of "σ ∘⇩s α"]
by (auto simp del: subst_subst_compose)
hence "send⟨occurs (Var x)⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(2) by blast
thus ?thesis using unlabel_append[of A] by fastforce
qed
qed simp
lemma reachable_constraints_db⇩l⇩s⇩s⇩t_set_args_empty:
assumes 𝒜: "𝒜 ∈ reachable_constraints P"
and PP: "list_all wellformed_transaction P"
and admissible_transaction_updates:
"let f = (λT. ∀x ∈ set (unlabel (transaction_updates T)).
is_Update x ∧ is_Var (the_elem_term x) ∧ is_Fun_Set (the_set_term x) ∧
fst (the_Var (the_elem_term x)) = TAtom Value)
in list_all f P"
and d: "(t, s) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
shows "∃ss. s = Fun (Set ss) []"
using 𝒜 d
proof (induction)
case (step 𝒜 TT σ α)
let ?TT = "transaction_strand TT ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
let ?TTu = "unlabel ?TT"
let ?TTd = "dual⇩l⇩s⇩s⇩t ?TT"
let ?TTdu = "unlabel ?TTd"
from step(6) have "(t, s) ∈ set (db'⇩s⇩s⇩t ?TTdu ℐ (db'⇩s⇩s⇩t (unlabel 𝒜) ℐ []))"
unfolding db⇩s⇩s⇩t_def by (simp add: db⇩s⇩s⇩t_append)
hence "(t, s) ∈ set (db'⇩s⇩s⇩t (unlabel 𝒜) ℐ []) ∨
(∃t' s'. insert⟨t',s'⟩ ∈ set ?TTdu ∧ t = t' ⋅ ℐ ∧ s = s' ⋅ ℐ)"
using db⇩s⇩s⇩t_in_cases[of t "s" ?TTdu ℐ] by metis
thus ?case
proof
assume "∃t' s'. insert⟨t',s'⟩ ∈ set ?TTdu ∧ t = t' ⋅ ℐ ∧ s = s' ⋅ ℐ"
then obtain t' s' where t's'_p: "insert⟨t',s'⟩ ∈ set ?TTdu" "t = t' ⋅ ℐ" "s = s' ⋅ ℐ" by metis
then obtain lll where "(lll, insert⟨t',s'⟩) ∈ set ?TTd" by (meson unlabel_mem_has_label)
hence "(lll, insert⟨t',s'⟩) ∈ set (transaction_strand TT ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
using dual⇩l⇩s⇩s⇩t_steps_iff(4) by blast
hence "insert⟨t',s'⟩ ∈ set ?TTu" by (meson unlabel_in)
hence "insert⟨t',s'⟩ ∈ set ((unlabel (transaction_strand TT)) ⋅⇩s⇩s⇩t σ ∘⇩s α)"
by (simp add: subst_lsst_unlabel)
hence "insert⟨t',s'⟩ ∈ (λx. x ⋅⇩s⇩s⇩t⇩p σ ∘⇩s α) ` set (unlabel (transaction_strand TT))"
unfolding subst_apply_stateful_strand_def by auto
then obtain u where "u ∈ set (unlabel (transaction_strand TT)) ∧ u ⋅⇩s⇩s⇩t⇩p σ ∘⇩s α = insert⟨t',s'⟩"
by auto
hence "∃t'' s''. insert⟨t'',s''⟩ ∈ set (unlabel (transaction_strand TT)) ∧
t' = t'' ⋅ σ ∘⇩s α ∧ s' = s'' ⋅ σ ∘⇩s α"
by (cases u) auto
then obtain t'' s'' where t''s''_p:
"insert⟨t'',s''⟩ ∈ set (unlabel (transaction_strand TT)) ∧
t' = t'' ⋅ σ ∘⇩s α ∧ s' = s'' ⋅ σ ∘⇩s α"
by auto
hence "insert⟨t'',s''⟩ ∈ set (unlabel (transaction_updates TT))"
using is_Update_in_transaction_updates[of "insert⟨t'',s''⟩" TT]
using PP step(2) unfolding list_all_iff by auto
moreover have "∀x∈set (unlabel (transaction_updates TT)). is_Fun_Set (the_set_term x)"
using step(2) admissible_transaction_updates unfolding is_Fun_Set_def list_all_iff by auto
ultimately have "is_Fun_Set (the_set_term (insert⟨t'',s''⟩))" by auto
moreover have "s' = s'' ⋅ σ ∘⇩s α" using t''s''_p by blast
ultimately have "is_Fun_Set (the_set_term (insert⟨t',s'⟩))" by (auto simp add: is_Fun_Set_subst)
hence "is_Fun_Set s" by (simp add: t's'_p(3) is_Fun_Set_subst)
thus ?case using is_Fun_Set_exi by auto
qed (auto simp add: step db⇩s⇩s⇩t_def)
qed auto
lemma reachable_constraints_occurs_fact_ik_ground:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "occurs t ∈ ik⇩l⇩s⇩s⇩t A"
shows "fv (occurs t) = {}"
proof -
have 0: "admissible_transaction T"
when "T ∈ set P" for T
using P that unfolding list_all_iff by simp
have 1: "wellformed_transaction T"
when "T ∈ set P" for T
using 0[OF that] unfolding admissible_transaction_def by simp
have 2: "ik⇩l⇩s⇩s⇩t (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)) =
(ik⇩l⇩s⇩s⇩t A) ∪ (trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t θ)"
when "T ∈ set P" for T θ and A::"('fun,'atom,'sets,'lbl) prot_constr"
using dual_transaction_ik_is_transaction_send'[OF 1[OF that]] by fastforce
have 3: "admissible_transaction_occurs_checks T"
when "T ∈ set P" for T
using 0[OF that] unfolding admissible_transaction_def by simp
show ?thesis using 𝒜_reach t
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α) thus ?case
proof (cases "occurs t ∈ ik⇩l⇩s⇩s⇩t A")
case False
hence "occurs t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α"
using 2[OF step.hyps(2)] step.prems by blast
hence "send⟨occurs t⟩ ∈ set (unlabel (transaction_send T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using wellformed_transaction_send_receive_subst_trm_cases(2)[OF 1[OF step.hyps(2)]]
by blast
then obtain s where s:
"send⟨occurs s⟩ ∈ set (unlabel (transaction_send T))" "t = s ⋅ σ ∘⇩s α"
using transaction_fresh_subst_transaction_renaming_subst_occurs_fact_send_receive(1)[
OF step.hyps(3,4) 1[OF step.hyps(2)]]
transaction_strand_subst_subsets(10)
by blast
obtain x where x: "x ∈ set (transaction_fresh T)" "s = Var x"
using s(1) 3[OF step.hyps(2)]
unfolding admissible_transaction_occurs_checks_def
by fastforce
have "fv t = {}"
using transaction_fresh_subst_transaction_renaming_subst_range(1)[OF step.hyps(3,4) x(1)]
s(2) x(2)
by (auto simp del: subst_subst_compose)
thus ?thesis by simp
qed simp
qed simp
qed
lemma reachable_constraints_occurs_fact_ik_funs_terms:
fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
shows "∀s ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I). OccursFact ∉ ⋃(funs_term ` set (snd (Ana s)))" (is "?A A")
and "∀s ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I). OccursSec ∉ ⋃(funs_term ` set (snd (Ana s)))" (is "?B A")
and "Fun OccursSec [] ∉ ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I" (is "?C A")
and "∀x ∈ vars⇩l⇩s⇩s⇩t A. I x ≠ Fun OccursSec []" (is "?D A")
proof -
have T_adm: "admissible_transaction T" when "T ∈ set P" for T
using P that unfolding list_all_iff by simp
have T_valid: "wellformed_transaction T" when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by blast
have T_occ: "admissible_transaction_occurs_checks T" when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by blast
have ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t I" by (metis ℐ welltyped_constraint_model_def)
have ℐ_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (subst_range I)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def)
have ℐ_grounds: "fv (I x) = {}" "∃f T. I x = Fun f T" for x
using ℐ interpretation_grounds[of I, of "Var x"] empty_fv_exists_fun[of "I x"]
unfolding welltyped_constraint_model_def constraint_model_def by auto
have 00: "fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⊆ vars_transaction T"
"fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))) = fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))"
for T::"('fun,'atom,'sets,'lbl) prot_transaction"
using fv_trms⇩s⇩s⇩t_subset(1)[of "unlabel (transaction_send T)"] vars_transaction_unfold
fv_subterms_set[of "trms⇩l⇩s⇩s⇩t (transaction_send T)"]
by blast+
have 0: "∀x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)). ∃a. Γ (Var x) = TAtom a"
"∀x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)). Γ (Var x) ≠ TAtom OccursSecType"
"∀x ∈ fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))). ∃a. Γ (Var x) = TAtom a"
"∀x ∈ fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))). Γ (Var x) ≠ TAtom OccursSecType"
"∀x ∈ vars_transaction T. ∃a. Γ (Var x) = TAtom a"
"∀x ∈ vars_transaction T. Γ (Var x) ≠ TAtom OccursSecType"
when "T ∈ set P" for T
using admissible_transaction_occurs_fv_types[OF T_adm[OF that]] 00
by blast+
have 1: "ik⇩l⇩s⇩s⇩t (A@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)) ⋅⇩s⇩e⇩t I =
(ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I) ∪ (trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t θ ⋅⇩s⇩e⇩t I)"
when "T ∈ set P" for T θ and A::"('fun,'atom,'sets,'lbl) prot_constr"
using dual_transaction_ik_is_transaction_send'[OF T_valid[OF that]]
by fastforce
have 2: "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t θ ⋅⇩s⇩e⇩t I) =
subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t θ ⋅⇩s⇩e⇩t I"
when "T ∈ set P" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" for T θ
using wt_subst_TAtom_subterms_set_subst[OF wt_subst_compose[OF θ(1) ℐ_wt] 0(1)[OF that(1)]]
wf_trm_subst_rangeD[OF wf_trms_subst_compose[OF θ(2) ℐ_wf⇩t⇩r⇩m⇩s]]
by auto
have 3: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)" "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
when "T ∈ set P" "transaction_fresh_subst σ T A" "transaction_renaming_subst α P A"
for σ α and T::"('fun,'atom,'sets,'lbl) prot_transaction"
and A::"('fun,'atom,'sets,'lbl) prot_constr"
using protocol_transaction_vars_TAtom_typed(3)[of T] P that(1)
transaction_fresh_subst_transaction_renaming_wt[OF that(2,3)]
transaction_fresh_subst_range_wf_trms[OF that(2)]
transaction_renaming_subst_range_wf_trms[OF that(3)]
wf_trms_subst_compose
by simp_all
have 4: "∀s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)).
OccursFact ∉ ⋃(funs_term ` set (snd (Ana s))) ∧
OccursSec ∉ ⋃(funs_term ` set (snd (Ana s)))"
when T: "T ∈ set P" for T
proof
fix t assume t: "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))"
then obtain s where s: "send⟨s⟩ ∈ set (unlabel (transaction_send T))" "t ∈ subterms s"
using wellformed_transaction_unlabel_cases(5)[OF T_valid[OF T]]
by fastforce
have s_occ: "∃x. s = occurs (Var x)" when "OccursFact ∈ funs_term t ∨ OccursSec ∈ funs_term t"
proof -
have "OccursFact ∈ funs_term s ∨ OccursSec ∈ funs_term s"
using that subtermeq_imp_funs_term_subset[OF s(2)]
by blast
thus ?thesis
using s T_occ[OF T]
unfolding admissible_transaction_occurs_checks_def
by fastforce
qed
obtain K T' where K: "Ana t = (K,T')" by moura
show "OccursFact ∉ ⋃(funs_term ` set (snd (Ana t))) ∧
OccursSec ∉ ⋃(funs_term ` set (snd (Ana t)))"
proof (rule ccontr)
assume "¬(OccursFact ∉ ⋃(funs_term ` set (snd (Ana t))) ∧
OccursSec ∉ ⋃(funs_term ` set (snd (Ana t))))"
hence a: "OccursFact ∈ ⋃(funs_term ` set (snd (Ana t))) ∨
OccursSec ∈ ⋃(funs_term ` set (snd (Ana t)))"
by simp
hence "OccursFact ∈ ⋃(funs_term ` set T') ∨ OccursSec ∈ ⋃(funs_term ` set T')"
using K by simp
hence "OccursFact ∈ funs_term t ∨ OccursSec ∈ funs_term t"
using Ana_subterm[OF K] funs_term_subterms_eq(1)[of t] by blast
then obtain x where x: "t ∈ subterms (occurs (Var x))"
using s(2) s_occ by blast
thus False using a by fastforce
qed
qed
have 5: "OccursFact ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
"OccursSec ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
when σα: "transaction_fresh_subst σ T A" "transaction_renaming_subst α P A"
for σ α and T::"('fun,'atom,'sets,'lbl) prot_transaction"
and A::"('fun,'atom,'sets,'lbl) prot_constr"
proof -
have "OccursFact ∉ funs_term t" "OccursSec ∉ funs_term t"
when "t ∈ subst_range (σ ∘⇩s α)" for t
using transaction_fresh_subst_transaction_renaming_subst_range'[OF σα that]
by auto
thus "OccursFact ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
"OccursSec ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
by blast+
qed
have 6: "I x ≠ Fun OccursSec []" "∄t. I x = occurs t" "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
when T: "T ∈ set P"
and σα: "transaction_fresh_subst σ T A" "transaction_renaming_subst α P A"
and x: "Var x ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α"
for x σ α and T::"('fun,'atom,'sets,'lbl) prot_transaction"
and A::"('fun,'atom,'sets,'lbl) prot_constr"
proof -
obtain t where t: "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" "t ⋅ (σ ∘⇩s α) = Var x"
using x by moura
then obtain y where y: "t = Var y" by (cases t) auto
have "∃a. Γ t = TAtom a ∧ a ≠ OccursSecType"
using 0(1,2)[OF T] t(1) y
by force
thus "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
using wt_subst_trm''[OF 3(1)[OF T σα]] wt_subst_trm''[OF ℐ_wt] t(2)
by (metis subst_apply_term.simps(1))
thus "I x ≠ Fun OccursSec []" "∄t. I x = occurs t"
by auto
qed
have 7: "I x ≠ Fun OccursSec []" "∄t. I x = occurs t" "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
when T: "T ∈ set P"
and σα: "transaction_fresh_subst σ T A" "transaction_renaming_subst α P A"
and x: "x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
for x σ α and T::"('fun,'atom,'sets,'lbl) prot_transaction"
and A::"('fun,'atom,'sets,'lbl) prot_constr"
proof -
obtain y where y: "y ∈ vars_transaction T" "x ∈ fv ((σ ∘⇩s α) y)"
using x by auto
hence y': "(σ ∘⇩s α) y = Var x"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF σα]
by (cases "(σ ∘⇩s α) y ∈ subst_range (σ ∘⇩s α)") force+
have "∃a. Γ (Var y) = TAtom a ∧ a ≠ OccursSecType"
using 0(5,6)[OF T] y
by force
thus "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
using wt_subst_trm''[OF 3(1)[OF T σα]] wt_subst_trm''[OF ℐ_wt] y'
by (metis subst_apply_term.simps(1))
thus "I x ≠ Fun OccursSec []" "∄t. I x = occurs t"
by auto
qed
have 8: "I x ≠ Fun OccursSec []" "∄t. I x = occurs t" "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
when T: "T ∈ set P"
and σα: "transaction_fresh_subst σ T A" "transaction_renaming_subst α P A"
and x: "Var x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α"
for x σ α and T::"('fun,'atom,'sets,'lbl) prot_transaction"
and A::"('fun,'atom,'sets,'lbl) prot_constr"
proof -
obtain t where t: "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))" "t ⋅ (σ ∘⇩s α) = Var x"
using x by moura
then obtain y where y: "t = Var y" by (cases t) auto
have "∃a. Γ t = TAtom a ∧ a ≠ OccursSecType"
using 0(3,4)[OF T] t(1) y
by force
thus "∃a. Γ (I x) = TAtom a ∧ a ≠ OccursSecType"
using wt_subst_trm''[OF 3(1)[OF T σα]] wt_subst_trm''[OF ℐ_wt] t(2)
by (metis subst_apply_term.simps(1))
thus "I x ≠ Fun OccursSec []" "∄t. I x = occurs t"
by auto
qed
have s_fv: "fv s ⊆ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
when s: "s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α"
and T: "T ∈ set P"
for s and σ α::"('fun,'atom,'sets) prot_subst" and T::"('fun,'atom,'sets,'lbl) prot_transaction"
proof
fix x assume "x ∈ fv s"
hence "x ∈ fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α)"
using s by auto
hence *: "x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α)"
using fv_subterms_set_subst' by fast
have **: "list_all is_Send (unlabel (transaction_send T))"
using T_valid[OF T] unfolding wellformed_transaction_def by blast
have "x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars⇩l⇩s⇩s⇩t (transaction_send T))"
proof -
obtain t where t: "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" "x ∈ fv (t ⋅ σ ∘⇩s α)"
using * by fastforce
hence "fv t ⊆ vars⇩l⇩s⇩s⇩t (transaction_send T)"
using fv_trms⇩s⇩s⇩t_subset(1)[of "unlabel (transaction_send T)"]
by auto
thus ?thesis using t(2) subst_apply_fv_subset by fast
qed
thus "x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
using vars_transaction_unfold[of T] by fastforce
qed
show "?A A" using 𝒜_reach
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
have *: "∀s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)).
OccursFact ∉ ⋃(funs_term ` set (snd (Ana s)))"
using 4[OF step.hyps(2)] by blast
have "∀s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I.
OccursFact ∉ ⋃(funs_term ` set (snd (Ana s)))"
proof
fix t assume t: "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I"
then obtain s u where su:
"s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α" "s ⋅ I = t"
"u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))" "u ⋅ σ ∘⇩s α = s"
by force
obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by moura
have *: "OccursFact ∉ ⋃(funs_term ` set Tu)"
"OccursFact ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
"OccursFact ∉ ⋃(funs_term ` ⋃(((set ∘ snd ∘ Ana) ` subst_range (σ ∘⇩s α))))"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
4[OF step.hyps(2)] su(3) KTu
by fastforce+
have "OccursFact ∉ ⋃(funs_term ` set (Tu ⋅⇩l⇩i⇩s⇩t σ ∘⇩s α))"
proof -
{ fix f assume f: "f ∈ ⋃(funs_term ` set (Tu ⋅⇩l⇩i⇩s⇩t σ ∘⇩s α))"
then obtain tf where tf: "tf ∈ set Tu" "f ∈ funs_term (tf ⋅ σ ∘⇩s α)" by moura
hence "f ∈ funs_term tf ∨ f ∈ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
using funs_term_subst[of tf "σ ∘⇩s α"] by force
hence "f ≠ OccursFact" using *(1,2) tf(1) by blast
} thus ?thesis by metis
qed
hence **: "OccursFact ∉ ⋃(funs_term ` set (snd (Ana s)))"
proof (cases u)
case (Var xu)
hence "s = (σ ∘⇩s α) xu" using su(4) by (metis subst_apply_term.simps(1))
thus ?thesis using *(3) by fastforce
qed (use su(4) KTu Ana_subst'[of _ _ Ku Tu "σ ∘⇩s α"] in simp)
show "OccursFact ∉ ⋃(funs_term ` set (snd (Ana t)))"
proof (cases s)
case (Var sx)
then obtain a where a: "Γ (I sx) = Var a"
using su(1) 8(3)[OF step.hyps(2,3,4), of sx] by fast
hence "Ana (I sx) = ([],[])" by (metis ℐ_grounds(2) const_type_inv[THEN Ana_const])
thus ?thesis using Var su(2) by simp
next
case (Fun f S)
hence snd_Ana_t: "snd (Ana t) = snd (Ana s) ⋅⇩l⇩i⇩s⇩t I"
using su(2) Ana_subst'[of f S _ "snd (Ana s)" I] by (cases "Ana s") simp_all
{ fix g assume "g ∈ ⋃(funs_term ` set (snd (Ana t)))"
hence "g ∈ ⋃(funs_term ` set (snd (Ana s))) ∨
(∃x ∈ fv⇩s⇩e⇩t (set (snd (Ana s))). g ∈ funs_term (I x))"
using snd_Ana_t funs_term_subst[of _ I] by auto
hence "g ≠ OccursFact"
proof
assume "∃x ∈ fv⇩s⇩e⇩t (set (snd (Ana s))). g ∈ funs_term (I x)"
then obtain x where x: "x ∈ fv⇩s⇩e⇩t (set (snd (Ana s)))" "g ∈ funs_term (I x)" by moura
have "x ∈ fv s" using x(1) Ana_vars(2)[of s] by (cases "Ana s") auto
hence "x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
using s_fv[OF su(1) step.hyps(2)] by blast
then obtain a h U where h:
"I x = Fun h U" "Γ (I x) = Var a" "a ≠ OccursSecType" "arity h = 0"
using ℐ_grounds(2) 7(3)[OF step.hyps(2,3,4)] const_type_inv
by metis
hence "h ≠ OccursFact" by auto
moreover have "U = []" using h(1,2,4) const_type_inv_wf[of h U a] ℐ_wf⇩t⇩r⇩m⇩s by fastforce
ultimately show ?thesis using h(1) x(2) by auto
qed (use ** in blast)
} thus ?thesis by blast
qed
qed
thus ?case
using step.IH step.prems 1[OF step.hyps(2), of A "σ ∘⇩s α"]
2[OF step.hyps(2) 3[OF step.hyps(2,3,4)]]
by auto
qed simp
show "?B A" using 𝒜_reach
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
have "∀s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I.
OccursSec ∉ ⋃(funs_term ` set (snd (Ana s)))"
proof
fix t assume t: "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I"
then obtain s u where su:
"s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α" "s ⋅ I = t"
"u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))" "u ⋅ σ ∘⇩s α = s"
by force
obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by moura
have *: "OccursSec ∉ ⋃(funs_term ` set Tu)"
"OccursSec ∉ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
"OccursSec ∉ ⋃(funs_term ` ⋃(((set ∘ snd ∘ Ana) ` subst_range (σ ∘⇩s α))))"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
4[OF step.hyps(2)] su(3) KTu
by fastforce+
have "OccursSec ∉ ⋃(funs_term ` set (Tu ⋅⇩l⇩i⇩s⇩t σ ∘⇩s α))"
proof -
{ fix f assume f: "f ∈ ⋃(funs_term ` set (Tu ⋅⇩l⇩i⇩s⇩t σ ∘⇩s α))"
then obtain tf where tf: "tf ∈ set Tu" "f ∈ funs_term (tf ⋅ σ ∘⇩s α)" by moura
hence "f ∈ funs_term tf ∨ f ∈ ⋃(funs_term ` subst_range (σ ∘⇩s α))"
using funs_term_subst[of tf "σ ∘⇩s α"] by force
hence "f ≠ OccursSec" using *(1,2) tf(1) by blast
} thus ?thesis by metis
qed
hence **: "OccursSec ∉ ⋃(funs_term ` set (snd (Ana s)))"
proof (cases u)
case (Var xu)
hence "s = (σ ∘⇩s α) xu" using su(4) by (metis subst_apply_term.simps(1))
thus ?thesis using *(3) by fastforce
qed (use su(4) KTu Ana_subst'[of _ _ Ku Tu "σ ∘⇩s α"] in simp)
show "OccursSec ∉ ⋃(funs_term ` set (snd (Ana t)))"
proof (cases s)
case (Var sx)
then obtain a where a: "Γ (I sx) = Var a"
using su(1) 8(3)[OF step.hyps(2,3,4), of sx] by fast
hence "Ana (I sx) = ([],[])" by (metis ℐ_grounds(2) const_type_inv[THEN Ana_const])
thus ?thesis using Var su(2) by simp
next
case (Fun f S)
hence snd_Ana_t: "snd (Ana t) = snd (Ana s) ⋅⇩l⇩i⇩s⇩t I"
using su(2) Ana_subst'[of f S _ "snd (Ana s)" I] by (cases "Ana s") simp_all
{ fix g assume "g ∈ ⋃(funs_term ` set (snd (Ana t)))"
hence "g ∈ ⋃(funs_term ` set (snd (Ana s))) ∨
(∃x ∈ fv⇩s⇩e⇩t (set (snd (Ana s))). g ∈ funs_term (I x))"
using snd_Ana_t funs_term_subst[of _ I] by auto
hence "g ≠ OccursSec"
proof
assume "∃x ∈ fv⇩s⇩e⇩t (set (snd (Ana s))). g ∈ funs_term (I x)"
then obtain x where x: "x ∈ fv⇩s⇩e⇩t (set (snd (Ana s)))" "g ∈ funs_term (I x)" by moura
have "x ∈ fv s" using x(1) Ana_vars(2)[of s] by (cases "Ana s") auto
hence "x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
using s_fv[OF su(1) step.hyps(2)] by blast
then obtain a h U where h:
"I x = Fun h U" "Γ (I x) = Var a" "a ≠ OccursSecType" "arity h = 0"
using ℐ_grounds(2) 7(3)[OF step.hyps(2,3,4)] const_type_inv
by metis
hence "h ≠ OccursSec" by auto
moreover have "U = []" using h(1,2,4) const_type_inv_wf[of h U a] ℐ_wf⇩t⇩r⇩m⇩s by fastforce
ultimately show ?thesis using h(1) x(2) by auto
qed (use ** in blast)
} thus ?thesis by blast
qed
qed
thus ?case
using step.IH step.prems 1[OF step.hyps(2), of A "σ ∘⇩s α"]
2[OF step.hyps(2) 3[OF step.hyps(2,3,4)]]
by auto
qed simp
show "?C A" using 𝒜_reach
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
have *: "Fun OccursSec [] ∉ trms⇩l⇩s⇩s⇩t (transaction_send T)"
using wellformed_transaction_unlabel_cases(5)[OF T_valid[OF step.hyps(2)]]
T_occ[OF step.hyps(2)]
unfolding admissible_transaction_occurs_checks_def
by fastforce
have **: "Fun OccursSec [] ∉ subst_range (σ ∘⇩s α)"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
by auto
have "Fun OccursSec [] ∉ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I"
proof
assume "Fun OccursSec [] ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α ⋅⇩s⇩e⇩t I"
then obtain s where "s ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α" "s ⋅ I = Fun OccursSec []"
by moura
moreover have "Fun OccursSec [] ∉ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α"
proof
assume "Fun OccursSec [] ∈ trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α"
then obtain u where "u ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" "u ⋅ σ ∘⇩s α = Fun OccursSec []"
by moura
thus False using * ** by (cases u) (force simp del: subst_subst_compose)+
qed
ultimately show False using 6[OF step.hyps(2,3,4)] by (cases s) auto
qed
thus ?case using step.IH step.prems 1[OF step.hyps(2), of A "σ ∘⇩s α"] by fast
qed simp
show "?D A" using 𝒜_reach
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
{ fix x assume x: "x ∈ vars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
hence x': "x ∈ vars⇩s⇩s⇩t (unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α)"
by (metis vars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq unlabel_subst)
hence "x ∈ vars_transaction T ∨ x ∈ fv⇩s⇩e⇩t ((σ ∘⇩s α) ` vars_transaction T)"
using vars⇩s⇩s⇩t_subst_cases[OF x'] by metis
moreover have "I x ≠ Fun OccursSec []" when "x ∈ vars_transaction T"
using that 0(5,6)[OF step.hyps(2)] wt_subst_trm''[OF ℐ_wt, of "Var x"]
by fastforce
ultimately have "I x ≠ Fun OccursSec []"
using 7(1)[OF step.hyps(2,3,4), of x]
by blast
} thus ?case using step.IH by auto
qed simp
qed
lemma reachable_constraints_occurs_fact_ik_subst_aux:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ ik⇩l⇩s⇩s⇩t A" "t ⋅ I = occurs s"
shows "∃u. t = occurs u"
proof -
have "wt⇩s⇩u⇩b⇩s⇩t I"
using ℐ unfolding welltyped_constraint_model_def constraint_model_def by metis
hence 0: "Γ t = Γ (occurs s)"
using t(2) wt_subst_trm'' by metis
have 1: "Γ⇩v ` fv⇩l⇩s⇩s⇩t A ⊆ (⋃T ∈ set P. Γ⇩v ` fv_transaction T)"
"∀T ∈ set P. ∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
using reachable_constraints_TAtom_types(1)[OF 𝒜_reach]
protocol_transaction_vars_TAtom_typed(2,3) P
by fast+
show ?thesis
proof (cases t)
case (Var x)
thus ?thesis
using 0 1 t(1) var_subterm_ik⇩s⇩s⇩t_is_fv⇩s⇩s⇩t[of x "unlabel A"]
by fastforce
next
case (Fun f T)
hence 2: "f = OccursFact" "length T = Suc (Suc 0)" "T ! 0 ⋅ I = Fun OccursSec []"
using t(2) by auto
have "T ! 0 = Fun OccursSec []"
proof (cases "T ! 0")
case (Var y)
hence "I y = Fun OccursSec []" using Fun 2(3) by simp
moreover have "Var y ∈ set T" using Var 2(2) length_Suc_conv[of T 1] by auto
hence "y ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t A)" using Fun t(1) by force
hence "y ∈ vars⇩l⇩s⇩s⇩t A"
using fv_ik_subset_fv_sst'[of "unlabel A"] vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel A"]
by blast
ultimately have False
using reachable_constraints_occurs_fact_ik_funs_terms(4)[OF 𝒜_reach ℐ P]
by blast
thus ?thesis by simp
qed (use 2(3) in simp)
moreover have "∃u u'. T = [u,u']"
using 2(2) by (metis (no_types, lifting) Suc_length_conv length_0_conv)
ultimately show ?thesis using Fun 2(1,2) by force
qed
qed
lemma reachable_constraints_occurs_fact_ik_subst:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "occurs t ∈ ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I"
shows "occurs t ∈ ik⇩l⇩s⇩s⇩t A"
proof -
have ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t I"
using ℐ unfolding welltyped_constraint_model_def constraint_model_def by metis
obtain s where s: "s ∈ ik⇩l⇩s⇩s⇩t A" "s ⋅ I = occurs t"
using t by auto
hence u: "∃u. s = occurs u"
using ℐ_wt reachable_constraints_occurs_fact_ik_subst_aux[OF 𝒜_reach ℐ P]
by blast
hence "fv s = {}"
using reachable_constraints_occurs_fact_ik_ground[OF 𝒜_reach P] s
by fast
thus ?thesis
using s u subst_ground_ident[of s I]
by argo
qed
lemma reachable_constraints_occurs_fact_send_in_ik:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "send⟨occurs (Var x)⟩ ∈ set (unlabel A)"
shows "occurs (I x) ∈ ik⇩l⇩s⇩s⇩t A"
using 𝒜_reach ℐ x
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
define θ where "θ ≡ σ ∘⇩s α"
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ)"
have T_adm: "admissible_transaction T"
using P step.hyps(2) unfolding list_all_iff by blast
have T_valid: "wellformed_transaction T"
using T_adm unfolding admissible_transaction_def by blast
have T_adm_occ: "admissible_transaction_occurs_checks T"
using T_adm unfolding admissible_transaction_def by blast
have ℐ_is_T_model: "strand_sem_stateful (ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I) (set (db⇩l⇩s⇩s⇩t A I)) (unlabel T') I"
using step.prems unlabel_append[of A T'] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of "unlabel A" I "[]"]
strand_sem_append_stateful[of "{}" "{}" "unlabel A" "unlabel T'" I]
by (simp add: T'_def θ_def welltyped_constraint_model_def constraint_model_def db⇩s⇩s⇩t_def)
show ?case
proof (cases "send⟨occurs (Var x)⟩ ∈ set (unlabel A)")
case False
hence "send⟨occurs (Var x)⟩ ∈ set (unlabel T')"
using step.prems(2) unfolding T'_def θ_def by simp
hence "receive⟨occurs (Var x)⟩ ∈ set (unlabel (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(2) unfolding T'_def by blast
then obtain y where y:
"receive⟨occurs (Var y)⟩ ∈ set (unlabel (transaction_receive T))"
"θ y = Var x"
using transaction_fresh_subst_transaction_renaming_subst_occurs_fact_send_receive(2)[
OF step.hyps(3,4) T_valid]
subst_to_var_is_var[of _ θ x]
unfolding θ_def by (force simp del: subst_subst_compose)
hence "receive⟨occurs (Var y) ⋅ θ⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t θ))"
using subst_lsst_unlabel_member[of "receive⟨occurs (Var y)⟩" "transaction_receive T" θ]
by fastforce
hence "ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I ⊢ occurs (Var y) ⋅ θ ⋅ I"
using wellformed_transaction_sem_receives[
OF T_valid, of "ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I" "set (db⇩l⇩s⇩s⇩t A I)" θ I "occurs (Var y) ⋅ θ"]
ℐ_is_T_model
by (metis T'_def)
hence *: "ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t I ⊢ occurs (θ y ⋅ I)"
by auto
have "occurs (θ y ⋅ I) ∈ ik⇩l⇩s⇩s⇩t A"
using deduct_occurs_in_ik[OF *]
reachable_constraints_occurs_fact_ik_subst[
OF step.hyps(1) welltyped_constraint_model_prefix[OF step.prems(1)] P, of "θ y ⋅ I"]
reachable_constraints_occurs_fact_ik_funs_terms[
OF step.hyps(1) welltyped_constraint_model_prefix[OF step.prems(1)] P]
by blast
thus ?thesis using y(2) by simp
qed (simp add: step.IH[OF welltyped_constraint_model_prefix[OF step.prems(1)]])
qed simp
lemma reachable_contraints_fv_bvars_subset:
assumes A: "A ∈ reachable_constraints P"
shows "bvars⇩l⇩s⇩s⇩t A ⊆ (⋃T ∈ set P. bvars_transaction T)"
using assms
proof (induction A rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
let ?T' = "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
show ?case
using step.IH step.hyps(2)
bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of ?T']
bvars⇩l⇩s⇩s⇩t_subst[of "transaction_strand T" "σ ∘⇩s α"]
bvars⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel (dual⇩l⇩s⇩s⇩t ?T')"]
unlabel_append[of 𝒜 "dual⇩l⇩s⇩s⇩t ?T'"]
by (metis (no_types, lifting) SUP_upper Un_subset_iff)
qed simp
lemma reachable_contraints_fv_disj:
assumes A: "A ∈ reachable_constraints P"
shows "fv⇩l⇩s⇩s⇩t A ∩ (⋃T ∈ set P. bvars_transaction T) = {}"
using A
proof (induction A rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
define T' where "T' ≡ transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
define X where "X ≡ ⋃T ∈ set P. bvars_transaction T"
have "fv⇩l⇩s⇩s⇩t T' ∩ X = {}"
using transaction_fresh_subst_transaction_renaming_subst_vars_disj(4)[OF step.hyps(3,4)]
transaction_fresh_subst_transaction_renaming_subst_vars_subset(4)[OF step.hyps(3,4,2)]
unfolding T'_def X_def by blast
hence "fv⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t T') ∩ X = {}"
using step.IH[unfolded X_def[symmetric]] fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of T'] by auto
thus ?case unfolding T'_def X_def by blast
qed simp
lemma reachable_contraints_fv_bvars_disj:
assumes P: "∀T ∈ set P. wellformed_transaction T"
and A: "A ∈ reachable_constraints P"
shows "fv⇩l⇩s⇩s⇩t A ∩ bvars⇩l⇩s⇩s⇩t A = {}"
using A
proof (induction A rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
note 0 = transaction_fresh_subst_transaction_renaming_subst_vars_disj[OF step.hyps(3,4)]
note 1 = transaction_fresh_subst_transaction_renaming_subst_vars_subset[OF step.hyps(3,4)]
have 2: "bvars⇩l⇩s⇩s⇩t 𝒜 ∩ fv⇩l⇩s⇩s⇩t T' = {}"
using 0(7) 1(4)[OF step.hyps(2)] fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq
unfolding T'_def by (metis (no_types) disjoint_iff_not_equal subset_iff)
have "bvars⇩l⇩s⇩s⇩t T' ⊆ ⋃(bvars_transaction ` set P)"
"fv⇩l⇩s⇩s⇩t 𝒜 ∩ ⋃(bvars_transaction ` set P) = {}"
using reachable_contraints_fv_bvars_subset[OF reachable_constraints.step[OF step.hyps]]
reachable_contraints_fv_disj[OF reachable_constraints.step[OF step.hyps]]
unfolding T'_def by auto
hence 3: "fv⇩l⇩s⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩s⇩t T' = {}" by blast
have "fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α) ∩ bvars_transaction T = {}"
using 0(4)[OF step.hyps(2)] 1(4)[OF step.hyps(2)] by blast
hence 4: "fv⇩l⇩s⇩s⇩t T' ∩ bvars⇩l⇩s⇩s⇩t T' = {}"
by (metis (no_types) T'_def fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq
unlabel_subst bvars⇩s⇩s⇩t_subst)
have "fv⇩l⇩s⇩s⇩t (𝒜@T') ∩ bvars⇩l⇩s⇩s⇩t (𝒜@T') = {}"
using 2 3 4 step.IH
unfolding unlabel_append[of 𝒜 T']
fv⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"]
bvars⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"]
by fast
thus ?case unfolding T'_def by blast
qed simp
lemma reachable_constraints_wf:
assumes P:
"∀T ∈ set P. wellformed_transaction T"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
and A: "A ∈ reachable_constraints P"
shows "wf⇩s⇩s⇩t (unlabel A)"
and "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A)"
proof -
have "wellformed_transaction T"
when "T ∈ set P" for T
using P(1) that by fast+
hence 0: "wf'⇩s⇩s⇩t (set (transaction_fresh T)) (unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T)))"
"fv⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T)) ∩ bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T)) = {}"
"wf⇩t⇩r⇩m⇩s (trms_transaction T)"
when T: "T ∈ set P" for T
unfolding admissible_transaction_terms_def
by (metis T wellformed_transaction_wf⇩s⇩s⇩t(1),
metis T wellformed_transaction_wf⇩s⇩s⇩t(2) fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq,
metis T wf⇩t⇩r⇩m⇩s_code P(2))
from A have "wf⇩s⇩s⇩t (unlabel A) ∧ wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A)"
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
let ?T' = "dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have IH: "wf'⇩s⇩s⇩t {} (unlabel A)" "fv⇩l⇩s⇩s⇩t A ∩ bvars⇩l⇩s⇩s⇩t A = {}" "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A)"
using step.IH by metis+
have 1: "wf'⇩s⇩s⇩t {} (unlabel (A@?T'))"
using protocol_transaction_wf_subst[OF 0(1)[OF step.hyps(2)] step.hyps(3,4)]
wf⇩s⇩s⇩t_vars_mono[of "{}"] wf⇩s⇩s⇩t_append[OF IH(1)]
by simp
have 2: "fv⇩l⇩s⇩s⇩t (A@?T') ∩ bvars⇩l⇩s⇩s⇩t (A@?T') = {}"
using reachable_contraints_fv_bvars_disj[OF P(1)]
reachable_constraints.step[OF step.hyps]
by blast
have "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t ?T')"
using trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq unlabel_subst
wf_trms_subst[
OF wf_trms_subst_compose[
OF transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]],
THEN wf⇩t⇩r⇩m⇩s_trms⇩s⇩s⇩t_subst,
OF 0(3)[OF step.hyps(2)]]
by metis
hence 3: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t (A@?T'))"
using IH(3) by auto
show ?case using 1 2 3 by force
qed simp
thus "wf⇩s⇩s⇩t (unlabel A)" "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A)" by metis+
qed
lemma reachable_constraints_no_Ana_Attack:
assumes 𝒜: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)"
shows "attack⟨n⟩ ∉ set (snd (Ana t))"
proof -
have T_adm: "admissible_transaction T" when "T ∈ set P" for T
using P that by blast
have T_adm_term: "admissible_transaction_terms T" when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by blast
have T_valid: "wellformed_transaction T" when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by blast
show ?thesis
using 𝒜 t
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step A T σ α) thus ?case
proof (cases "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t A)")
case False
hence "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)))"
using step.prems by simp
hence "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t σ ∘⇩s α)"
using dual_transaction_ik_is_transaction_send'[OF T_valid[OF step.hyps(2)]]
by metis
hence "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T)) ⋅⇩s⇩e⇩t σ ∘⇩s α"
using transaction_fresh_subst_transaction_renaming_subst_trms[
OF step.hyps(3,4), of "transaction_send T"]
wellformed_transaction_unlabel_cases(5)[OF T_valid[OF step.hyps(2)]]
by fastforce
then obtain s where s: "s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_send T))" "t = s ⋅ σ ∘⇩s α"
by moura
hence s': "attack⟨n⟩ ∉ set (snd (Ana s))"
using admissible_transaction_no_Ana_Attack[OF T_adm_term[OF step.hyps(2)]]
trms_transaction_unfold[of T]
by blast
note * = transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
show ?thesis
proof
assume n: "attack⟨n⟩ ∈ set (snd (Ana t))"
thus False
proof (cases s)
case (Var x) thus ?thesis using Var * n s(2) by (force simp del: subst_subst_compose)
next
case (Fun f T)
hence "attack⟨n⟩ ∈ set (snd (Ana s)) ⋅⇩s⇩e⇩t σ ∘⇩s α"
using Ana_subst'[of f T _ "snd (Ana s)" "σ ∘⇩s α"] s(2) s' n
by (cases "Ana s") auto
hence "attack⟨n⟩ ∈ set (snd (Ana s)) ∨ attack⟨n⟩ ∈ subst_range (σ ∘⇩s α)"
using const_mem_subst_cases' by fast
thus ?thesis using * s' by blast
qed
qed
qed simp
qed simp
qed
lemma constraint_model_Value_term_is_Val:
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "Γ⇩v x = TAtom Value" "x ∈ fv⇩l⇩s⇩s⇩t A"
shows "∃n. I x = Fun (Val (n,False)) []"
using reachable_constraints_occurs_fact_send_ex[OF 𝒜_reach P x]
reachable_constraints_occurs_fact_send_in_ik[OF 𝒜_reach ℐ P]
reachable_constraints_occurs_fact_ik_case[OF 𝒜_reach P]
by fast
lemma constraint_model_Value_term_is_Val':
assumes 𝒜_reach: "A ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model I A"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "(TAtom Value, m) ∈ fv⇩l⇩s⇩s⇩t A"
shows "∃n. I (TAtom Value, m) = Fun (Val (n,False)) []"
using constraint_model_Value_term_is_Val[OF 𝒜_reach ℐ P _ x] by simp
lemma constraint_model_Value_var_in_constr_prefix:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
shows "∀x ∈ fv⇩l⇩s⇩s⇩t 𝒜. Γ⇩v x = TAtom Value
⟶ (∃B. prefix B 𝒜 ∧ x ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B))" (is "?P 𝒜")
using 𝒜_reach ℐ
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
have IH: "?P 𝒜" using step welltyped_constraint_model_prefix by fast
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have T_adm: "admissible_transaction T"
by (metis P step.hyps(2))
have T_valid: "wellformed_transaction T"
by (metis T_adm admissible_transaction_def)
have ℐ_is_T_model: "strand_sem_stateful (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) (set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)) (unlabel T') ℐ"
using step.prems unlabel_append[of 𝒜 T'] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of "unlabel 𝒜" ℐ "[]"]
strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "unlabel T'" ℐ]
by (simp add: T'_def welltyped_constraint_model_def constraint_model_def db⇩s⇩s⇩t_def)
have ℐ_interp: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def,
metis ℐ welltyped_constraint_model_def,
metis ℐ welltyped_constraint_model_def constraint_model_def)
have 1: "∃B. prefix B 𝒜 ∧ x ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
when x: "x ∈ fv⇩l⇩s⇩s⇩t T'" "Γ⇩v x = TAtom Value" for x
proof -
obtain n where n: "ℐ x = Fun n []" "is_Val n ∨ is_Abs n" "¬public n"
using constraint_model_Value_term_is_Val[
OF reachable_constraints.step[OF step.hyps] step.prems P x(2)]
x(1) fv⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel T'"] unlabel_append[of 𝒜 T']
unfolding T'_def by moura
have "x ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
using x(1) fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq unfolding T'_def by fastforce
then obtain y where y: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T)" "x ∈ fv ((σ ∘⇩s α) y)"
using fv⇩s⇩s⇩t_subst_obtain_var[of x "unlabel (transaction_strand T)" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by auto
have y_x: "(σ ∘⇩s α) y = Var x"
using y(2) transaction_fresh_subst_transaction_renaming_subst_range[OF step.hyps(3,4), of y]
by force
have "Γ ((σ ∘⇩s α) y) = TAtom Value" using x(2) y_x by simp
moreover have "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using protocol_transaction_vars_TAtom_typed(3) P(1) step.hyps(2)
transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
ultimately have y_val: "Γ⇩v y = TAtom Value"
by (metis wt⇩s⇩u⇩b⇩s⇩t_def Γ.simps(1))
have y_not_fresh: "y ∉ set (transaction_fresh T)"
using y(2) transaction_fresh_subst_transaction_renaming_subst_range(1)[OF step.hyps(3,4)]
by fastforce
have y_n: "Fun n [] = (σ ∘⇩s α) y ⋅ ℐ" using n y_x by simp
hence y_n': "Fun n [] = (σ ∘⇩s α ∘⇩s ℐ) y"
by (metis subst_subst_compose[of "Var y" "σ ∘⇩s α" ℐ] subst_apply_term.simps(1))
have "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∨ y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using wellformed_transaction_fv_in_receives_or_selects[OF T_valid] y(1) y_not_fresh by blast
hence n_cases:
"Fun n [] ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜) ∨
(∃z ∈ fv⇩l⇩s⇩s⇩t 𝒜. Γ⇩v z = TAtom Value ∧ ℐ z = Fun n [])"
proof
assume y_in: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T)"
then obtain t where t: "receive⟨t⟩ ∈ set (unlabel (transaction_receive T))" "y ∈ fv t"
using admissible_transaction_strand_step_cases(1)[OF T_adm]
by force
hence "receive⟨t ⋅ σ ∘⇩s α⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using subst_lsst_unlabel_member[of "receive⟨t⟩" "transaction_receive T" "σ ∘⇩s α"]
by fastforce
hence *: "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ σ ∘⇩s α ⋅ ℐ"
using wellformed_transaction_sem_receives[
OF T_valid, of "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ" "set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)" "σ ∘⇩s α" ℐ "t ⋅ σ ∘⇩s α"]
ℐ_is_T_model
by (metis T'_def)
have "∃a. Γ (ℐ x) = Var a" when "x ∈ fv⇩l⇩s⇩s⇩t 𝒜" for x
using that reachable_constraints_vars_TAtom_typed[OF step.hyps(1) P, of x]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"] wt_subst_trm''[OF ℐ_wt, of "Var x"]
by force
hence "∃f. ℐ x = Fun f []" when "x ∈ fv⇩l⇩s⇩s⇩t 𝒜" for x
using that wf_trm_subst[OF ℐ_wf⇩t⇩r⇩m⇩s, of "Var x"] wf_trm_Var[of x] const_type_inv_wf
empty_fv_exists_fun[OF interpretation_grounds[OF ℐ_interp], of "Var x"]
by (metis subst_apply_term.simps(1)[of x ℐ])
hence 𝒜_ik_ℐ_vals: "∀x ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜). ∃f. ℐ x = Fun f []"
using fv_ik_subset_fv_sst'[of "unlabel 𝒜"] vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"]
by blast
hence "subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) = subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜) ⋅⇩s⇩e⇩t ℐ"
using ik⇩s⇩s⇩t_subst[of "unlabel 𝒜" ℐ] unlabel_subst[of 𝒜 ℐ]
subterms_subst_lsst_ik[of 𝒜 ℐ]
by metis
moreover have "v ∈ fv⇩l⇩s⇩s⇩t 𝒜" when "v ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)" for v
by (meson contra_subsetD fv_ik_subset_fv_sst' that)
moreover have "Fun n [] ∈ subterms (t ⋅ σ ∘⇩s α ⋅ ℐ)"
using imageI[of "Var y" "subterms t" "λx. x ⋅ σ ∘⇩s α ∘⇩s ℐ"]
var_is_subterm[OF t(2)] subterms_subst_subset[of "σ ∘⇩s α ∘⇩s ℐ" t]
subst_subst_compose[of t "σ ∘⇩s α" ℐ] y_n'
by (auto simp del: subst_subst_compose)
hence "Fun n [] ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ)"
using private_fun_deduct_in_ik[OF *, of n "[]"] n(2,3)
unfolding is_Val_def is_Abs_def
by auto
hence "Fun n [] ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜) ∨
(∃z ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜). Fun n [] ∈ subterms (ℐ z))"
using const_subterm_subst_cases[of n _ ℐ]
by auto
hence "Fun n [] ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜) ∨ (∃z ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜). ℐ z = Fun n [])"
using 𝒜_ik_ℐ_vals by fastforce
hence "Fun n [] ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜) ∨
(∃z ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜). Γ⇩v z = TAtom Value ∧ ℐ z = Fun n [])"
using ℐ_wt n(2) unfolding wt⇩s⇩u⇩b⇩s⇩t_def is_Val_def is_Abs_def by force
ultimately show ?thesis using ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset[of "unlabel 𝒜"] by fast
next
assume y_in: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
then obtain s where s: "select⟨Var y,Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))"
using admissible_transaction_strand_step_cases(2)[OF T_adm]
by force
hence "select⟨(σ ∘⇩s α) y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using subst_lsst_unlabel_member
by fastforce
hence n_in_db: "(Fun n [], Fun (Set s) []) ∈ set (db'⇩s⇩s⇩t (unlabel 𝒜) ℐ [])"
using wellformed_transaction_sem_selects[
OF T_valid, of "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ" "set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)" "σ ∘⇩s α" ℐ
"(σ ∘⇩s α) y" "Fun (Set s) []"]
ℐ_is_T_model n y_x
unfolding T'_def db⇩s⇩s⇩t_def
by fastforce
obtain tn sn where tsn: "insert⟨tn,sn⟩ ∈ set (unlabel 𝒜)" "Fun n [] = tn ⋅ ℐ"
using db⇩s⇩s⇩t_in_cases[OF n_in_db] by force
have "Fun n [] = tn ∨ (∃z. Γ⇩v z = TAtom Value ∧ tn = Var z)"
using ℐ_wt tsn(2) n(2) unfolding wt⇩s⇩u⇩b⇩s⇩t_def is_Val_def is_Abs_def by (cases tn) auto
moreover have "tn ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" "fv tn ⊆ fv⇩l⇩s⇩s⇩t 𝒜"
using tsn(1) in_subterms_Union by force+
ultimately show ?thesis using tsn(2) by auto
qed
have x_nin_𝒜: "x ∉ fv⇩l⇩s⇩s⇩t 𝒜"
proof -
have "x ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
using x(1) fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq
unfolding T'_def
by fast
hence "x ∈ fv⇩s⇩s⇩t ((unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ) ⋅⇩s⇩s⇩t α)"
using transaction_fresh_subst_grounds_domain[OF step.hyps(3)] step.hyps(3)
labeled_stateful_strand_subst_comp[of σ "transaction_strand T" α]
unlabel_subst[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ" α]
unlabel_subst[of "transaction_strand T" σ]
by (simp add: transaction_fresh_subst_def range_vars_alt_def)
then obtain y where y: "α y = Var x"
using transaction_renaming_subst_var_obtain[OF _ step.hyps(4)]
by blast
thus ?thesis
using transaction_renaming_subst_range_notin_vars[OF step.hyps(4), of y]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"]
by auto
qed
from n_cases show ?thesis
proof
assume "∃z ∈ fv⇩l⇩s⇩s⇩t 𝒜. Γ⇩v z = TAtom Value ∧ ℐ z = Fun n []"
then obtain B where B: "prefix B 𝒜" "Fun n [] ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
by (metis IH n(1))
thus ?thesis
using n x_nin_𝒜 trms⇩s⇩s⇩t_unlabel_prefix_subset(1)[of B]
by (metis (no_types, hide_lams) self_append_conv subset_iff subterms⇩s⇩e⇩t_mono prefix_def)
qed (use n x_nin_𝒜 in fastforce)
qed
have "?P (𝒜@T')"
proof (intro ballI impI)
fix x assume x: "x ∈ fv⇩l⇩s⇩s⇩t (𝒜@T')" "Γ⇩v x = TAtom Value"
show "∃B. prefix B (𝒜@T') ∧ x ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
proof (cases "x ∈ fv⇩l⇩s⇩s⇩t 𝒜")
case False
hence x': "x ∈ fv⇩l⇩s⇩s⇩t T'" using x(1) unlabel_append[of 𝒜] fv⇩s⇩s⇩t_append[of "unlabel 𝒜"] by simp
then obtain B where B: "prefix B 𝒜" "x ∉ fv⇩l⇩s⇩s⇩t B" "ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using x(2) 1 by moura
thus ?thesis using prefix_prefix by fast
qed (use x(2) IH prefix_prefix in fast)
qed
thus ?case unfolding T'_def by blast
qed simp
lemma admissible_transaction_occurs_checks_prop:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and f: "f ∈ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
shows "is_Val f ⟹ ¬public f"
and "¬is_Abs f"
proof -
obtain x where x: "x ∈ fv⇩l⇩s⇩s⇩t 𝒜" "f ∈ funs_term (ℐ x)" using f by moura
obtain T where T: "Fun f T ⊑ ℐ x" using funs_term_Fun_subterm[OF x(2)] by moura
have ℐ_interp: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def,
metis ℐ welltyped_constraint_model_def,
metis ℐ welltyped_constraint_model_def constraint_model_def)
have 1: "Γ (Var x) = Γ (ℐ x)" using wt_subst_trm''[OF ℐ_wt, of "Var x"] by simp
hence "∃a. Γ (ℐ x) = Var a"
using x(1) reachable_constraints_vars_TAtom_typed[OF 𝒜_reach P, of x]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"]
by force
hence "∃f. ℐ x = Fun f []"
using x(1) wf_trm_subst[OF ℐ_wf⇩t⇩r⇩m⇩s, of "Var x"] wf_trm_Var[of x] const_type_inv_wf
empty_fv_exists_fun[OF interpretation_grounds[OF ℐ_interp], of "Var x"]
by (metis subst_apply_term.simps(1)[of x ℐ])
hence 2: "ℐ x = Fun f []" using x(2) by force
have "(is_Val f ⟶ ¬public f) ∧ ¬is_Abs f"
proof (cases "Γ⇩v x = TAtom Value")
case True
then obtain B where B: "prefix B 𝒜" "x ∉ fv⇩l⇩s⇩s⇩t B" "ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using constraint_model_Value_var_in_constr_prefix[OF 𝒜_reach ℐ P] x(1)
by fast
have "ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
using B(1,3) trms⇩s⇩s⇩t_append[of "unlabel B"] unlabel_append[of B]
unfolding prefix_def by auto
hence "f ∈ ⋃(funs_term ` trms⇩l⇩s⇩s⇩t 𝒜)"
using x(2) funs_term_subterms_eq(2)[of "trms⇩l⇩s⇩s⇩t 𝒜"] by blast
thus ?thesis
using reachable_constraints_val_funs_private[OF 𝒜_reach P]
by blast+
next
case False thus ?thesis using x 1 2 by (cases f) auto
qed
thus "is_Val f ⟹ ¬public f" "¬is_Abs f" by metis+
qed
lemma admissible_transaction_occurs_checks_prop':
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and f: "f ∈ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
shows "∄n. f = Val (n,True)"
and "∄n. f = Abs n"
using admissible_transaction_occurs_checks_prop[OF 𝒜_reach ℐ P f] by auto
lemma transaction_var_becomes_Val:
assumes 𝒜_reach: "𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α) ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and T: "T ∈ set P"
and x: "x ∈ fv_transaction T" "fst x = TAtom Value"
shows "∃n. Fun (Val (n,False)) [] = (σ ∘⇩s α) x ⋅ ℐ"
proof -
obtain m where m: "x = (TAtom Value, m)" by (metis x(2) eq_fst_iff)
have x_not_bvar: "x ∉ bvars_transaction T" "fv ((σ ∘⇩s α) x) ∩ bvars_transaction T = {}"
using x(1) transactions_fv_bvars_disj[OF P] T
transaction_fresh_subst_transaction_renaming_subst_vars_disj(2)[OF σ α, of x]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_strand T)"]
by blast+
show ?thesis
proof (cases "x ∈ subst_domain σ")
case True
then obtain n where "σ x = Fun (Val (n, False)) []"
using σ unfolding transaction_fresh_subst_def by fastforce
thus ?thesis using subst_compose[of σ α x] by simp
next
case False
hence "σ x = Var x" by auto
then obtain n where n: "(σ ∘⇩s α) x = Var (TAtom Value, n)"
using m transaction_renaming_subst_is_renaming[OF α] subst_compose[of σ α x]
by force
hence "(TAtom Value, n) ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
using x_not_bvar fv⇩s⇩s⇩t_subst_fv_subset[OF x(1), of "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by force
hence "∃n'. ℐ (TAtom Value, n) = Fun (Val (n',False)) []"
using constraint_model_Value_term_is_Val'[OF 𝒜_reach ℐ P, of n] x
fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
fv⇩s⇩s⇩t_append[of "unlabel 𝒜"] unlabel_append[of 𝒜]
by fastforce
thus ?thesis using n by simp
qed
qed
lemma reachable_constraints_SMP_subset:
assumes 𝒜: "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
shows "SMP (trms⇩l⇩s⇩s⇩t 𝒜) ⊆ SMP (⋃T ∈ set P. trms_transaction T)" (is "?A 𝒜")
and "SMP (pair`setops⇩s⇩s⇩t (unlabel 𝒜)) ⊆ SMP (⋃T∈set P. pair`setops_transaction T)" (is "?B 𝒜")
proof -
have "?A 𝒜 ∧ ?B 𝒜" using 𝒜
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step A T σ α)
define T' where "T' ≡ transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
define M where "M ≡ ⋃T ∈ set P. trms_transaction T"
define N where "N ≡ ⋃T ∈ set P. pair ` setops_transaction T"
let ?P = "λt. ∃s δ. s ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
let ?Q = "λt. ∃s δ. s ∈ N ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
have IH: "SMP (trms⇩l⇩s⇩s⇩t A) ⊆ SMP M" "SMP (pair ` setops⇩s⇩s⇩t (unlabel A)) ⊆ SMP N"
using step.IH by (metis M_def, metis N_def)
have σα_wt: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using P(1) step.hyps(2)
transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
have σα_wf: "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
have 0: "SMP (trms⇩l⇩s⇩s⇩t (A@dual⇩l⇩s⇩s⇩t T')) = SMP (trms⇩l⇩s⇩s⇩t A) ∪ SMP (trms⇩l⇩s⇩s⇩t T')"
"SMP (pair ` setops⇩s⇩s⇩t (unlabel (A@dual⇩l⇩s⇩s⇩t T'))) =
SMP (pair ` setops⇩s⇩s⇩t (unlabel A)) ∪ SMP (pair ` setops⇩s⇩s⇩t (unlabel T'))"
using trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of T']
setops⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of T']
trms⇩s⇩s⇩t_append[of "unlabel A" "unlabel (dual⇩l⇩s⇩s⇩t T')"]
setops⇩s⇩s⇩t_append[of "unlabel A" "unlabel (dual⇩l⇩s⇩s⇩t T')"]
unlabel_append[of A "dual⇩l⇩s⇩s⇩t T'"]
image_Un[of pair "setops⇩s⇩s⇩t (unlabel A)" "setops⇩s⇩s⇩t (unlabel T')"]
SMP_union[of "trms⇩l⇩s⇩s⇩t A" "trms⇩l⇩s⇩s⇩t T'"]
SMP_union[of "pair ` setops⇩s⇩s⇩t (unlabel A)" "pair ` setops⇩s⇩s⇩t (unlabel T')"]
by argo+
have 1: "SMP (trms⇩l⇩s⇩s⇩t T') ⊆ SMP M"
proof (intro SMP_subset_I ballI)
fix t show "t ∈ trms⇩l⇩s⇩s⇩t T' ⟹ ?P t"
using trms⇩s⇩s⇩t_wt_subst_ex[OF σα_wt σα_wf, of t "unlabel (transaction_strand T)"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"] step.hyps(2)
unfolding T'_def M_def by auto
qed
have 2: "SMP (pair ` setops⇩s⇩s⇩t (unlabel T')) ⊆ SMP N"
proof (intro SMP_subset_I ballI)
fix t show "t ∈ pair ` setops⇩s⇩s⇩t (unlabel T') ⟹ ?Q t"
using setops⇩s⇩s⇩t_wt_subst_ex[OF σα_wt σα_wf, of t "unlabel (transaction_strand T)"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"] step.hyps(2)
unfolding T'_def N_def by auto
qed
have "SMP (trms⇩l⇩s⇩s⇩t (A@dual⇩l⇩s⇩s⇩t T')) ⊆ SMP M"
"SMP (pair ` setops⇩s⇩s⇩t (unlabel (A@dual⇩l⇩s⇩s⇩t T'))) ⊆ SMP N"
using 0 1 2 IH by blast+
thus ?case unfolding T'_def M_def N_def by blast
qed (simp add: setops⇩s⇩s⇩t_def)
thus "?A 𝒜" "?B 𝒜" by metis+
qed
lemma reachable_constraints_no_Pair_fun:
assumes A: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
shows "Pair ∉ ⋃(funs_term ` SMP (trms⇩l⇩s⇩s⇩t A))"
using A
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have T_adm: "admissible_transaction T" using step.hyps(2) P unfolding list_all_iff by blast
have σα_wt: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using protocol_transaction_vars_TAtom_typed(3) P(1) step.hyps(2)
transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
have σα_wf: "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
have 0: "SMP (trms⇩l⇩s⇩s⇩t (A@T')) = SMP (trms⇩l⇩s⇩s⇩t A) ∪ SMP (trms⇩l⇩s⇩s⇩t T')"
using SMP_union[of "trms⇩l⇩s⇩s⇩t A" "trms⇩l⇩s⇩s⇩t T'"]
unlabel_append[of A T'] trms⇩s⇩s⇩t_append[of "unlabel A" "unlabel T'"]
by simp
have 1: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t T')"
using reachable_constraints_wf⇩t⇩r⇩m⇩s[OF _ reachable_constraints.step[OF step.hyps]]
admissible_transactions_wf⇩t⇩r⇩m⇩s P
trms⇩s⇩s⇩t_append[of "unlabel A"] unlabel_append[of A]
unfolding T'_def by force
have 2: "Pair ∉ ⋃(funs_term ` (subst_range (σ ∘⇩s α)))"
using transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)] by force
have "Pair ∉ ⋃(funs_term ` (trms_transaction T))"
using T_adm
unfolding admissible_transaction_def admissible_transaction_terms_def
by blast
hence "Pair ∉ funs_term t"
when t: "t ∈ trms⇩s⇩s⇩t (unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α)" for t
using 2 trms⇩s⇩s⇩t_funs_term_cases[OF t]
by force
hence 3: "Pair ∉ funs_term t" when t: "t ∈ trms⇩l⇩s⇩s⇩t T'" for t
using t unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unfolding T'_def by metis
have "∃a. Γ⇩v x = TAtom a" when "x ∈ vars_transaction T" for x
using that protocol_transaction_vars_TAtom_typed(1) P step.hyps(2)
by fast
hence "∃a. Γ⇩v x = TAtom a" when "x ∈ vars⇩s⇩s⇩t (unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α)" for x
using wt_subst_fv⇩s⇩e⇩t_termtype_subterm[OF _ σα_wt σα_wf, of x "vars_transaction T"]
vars⇩s⇩s⇩t_subst_cases[OF that]
by fastforce
hence "∃a. Γ⇩v x = TAtom a" when "x ∈ vars⇩l⇩s⇩s⇩t T'" for x
using that unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
vars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unfolding T'_def
by simp
hence "∃a. Γ⇩v x = TAtom a" when "x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t T')" for x
using that fv_trms⇩s⇩s⇩t_subset(1) by fast
hence "Pair ∉ funs_term (Γ (Var x))" when "x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t T')" for x
using that by fastforce
moreover have "Pair ∈ funs_term s"
when s: "Ana s = (K, M)" "Pair ∈ ⋃(funs_term ` set K)"
for s::"('fun,'atom,'sets) prot_term" and K M
proof (cases s)
case (Fun f S) thus ?thesis using s Ana_Fu_keys_not_pairs[of _ S K M] by (cases f) force+
qed (use s in simp)
ultimately have "Pair ∉ funs_term t" when t: "t ∈ SMP (trms⇩l⇩s⇩s⇩t T')" for t
using t 3 SMP_funs_term[OF t _ _ 1, of Pair] funs_term_type_iff by fastforce
thus ?case using 0 step.IH(1) unfolding T'_def by blast
qed simp
lemma reachable_constraints_setops_form:
assumes A: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A)"
shows "∃c s. t = pair (c, Fun (Set s) []) ∧ Γ c = TAtom Value"
using A t
proof (induction A rule: reachable_constraints.induct)
case (step A T σ α)
have T_adm: "admissible_transaction T" when "T ∈ set P" for T
using P that unfolding list_all_iff by simp
have T_adm':
"admissible_transaction_selects T"
"admissible_transaction_checks T"
"admissible_transaction_updates T"
when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by simp_all
have T_valid: "wellformed_transaction T" when "T ∈ set P" for T
using T_adm[OF that] unfolding admissible_transaction_def by blast
have σα_wt: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using protocol_transaction_vars_TAtom_typed(3) P(1) step.hyps(2)
transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
have σα_wf: "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
show ?case using step.IH
proof (cases "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A)")
case False
hence "t ∈ pair ` setops⇩s⇩s⇩t (unlabel (transaction_strand T) ⋅⇩s⇩s⇩t σ ∘⇩s α)"
using step.prems setops⇩s⇩s⇩t_append unlabel_append
setops⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
by fastforce
then obtain t' δ where t':
"t' ∈ pair ` setops⇩s⇩s⇩t (unlabel (transaction_strand T))"
"wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "t = t' ⋅ δ"
using setops⇩s⇩s⇩t_wt_subst_ex[OF σα_wt σα_wf] by blast
then obtain s s' where s: "t' = pair (s,s')"
using setops⇩s⇩s⇩t_are_pairs by fastforce
moreover have "InSet ac s s' = InSet Assign s s' ∨ InSet ac s s' = InSet Check s s'" for ac
by (cases ac) simp_all
ultimately have "∃n. s = Var (Var Value, n)" "∃u. s' = Fun (Set u) []"
using t'(1) setops⇩s⇩s⇩t_member_iff[of s s' "unlabel (transaction_strand T)"]
pair_in_pair_image_iff[of s s']
transaction_inserts_are_Value_vars[
OF T_valid[OF step.hyps(2)] T_adm'(3)[OF step.hyps(2)], of s s']
transaction_deletes_are_Value_vars[
OF T_valid[OF step.hyps(2)] T_adm'(3)[OF step.hyps(2)], of s s']
transaction_selects_are_Value_vars[
OF T_valid[OF step.hyps(2)] T_adm'(1)[OF step.hyps(2)], of s s']
transaction_inset_checks_are_Value_vars[
OF T_valid[OF step.hyps(2)] T_adm'(2)[OF step.hyps(2)], of s s']
transaction_notinset_checks_are_Value_vars[
OF T_valid[OF step.hyps(2)] T_adm'(2)[OF step.hyps(2)], of _ _ _ s s']
by metis+
then obtain ss n where ss: "t = pair (δ (Var Value, n), Fun (Set ss) [])"
using t'(4) s unfolding pair_def by force
have "Γ (δ (Var Value, n)) = TAtom Value" "wf⇩t⇩r⇩m (δ (Var Value, n))"
using t'(2) wt_subst_trm''[OF t'(2), of "Var (Var Value, n)"] apply simp
using t'(3) by (cases "(Var Value, n) ∈ subst_domain δ") auto
thus ?thesis using ss by blast
qed simp
qed (simp add: setops⇩s⇩s⇩t_def)
lemma reachable_constraints_setops_type:
fixes t::"('fun,'atom,'sets) prot_term"
assumes A: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A)"
shows "Γ t = TComp Pair [TAtom Value, TAtom SetType]"
proof -
obtain s c where s: "t = pair (c, Fun (Set s) [])" "Γ c = TAtom Value"
using reachable_constraints_setops_form[OF A P t] by moura
hence "(Fun (Set s) []::('fun,'atom,'sets) prot_term) ∈ trms⇩l⇩s⇩s⇩t A"
using t setops⇩s⇩s⇩t_member_iff[of c "Fun (Set s) []" "unlabel A"]
by force
hence "wf⇩t⇩r⇩m (Fun (Set s) []::('fun,'atom,'sets) prot_term)"
using reachable_constraints_wf(2) P A
unfolding admissible_transaction_def admissible_transaction_terms_def by blast
hence "arity (Set s) = 0" unfolding wf⇩t⇩r⇩m_def by simp
thus ?thesis using s unfolding pair_def by fastforce
qed
lemma reachable_constraints_setops_same_type_if_unifiable:
assumes A: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
shows "∀s ∈ pair ` setops⇩s⇩s⇩t (unlabel A). ∀t ∈ pair ` setops⇩s⇩s⇩t (unlabel A).
(∃δ. Unifier δ s t) ⟶ Γ s = Γ t"
(is "?P A")
using reachable_constraints_setops_type[OF A P] by simp
lemma reachable_constraints_setops_unfiable_if_wt_instance_unifiable:
assumes A: "A ∈ reachable_constraints P"
and P: "∀T ∈ set P. admissible_transaction T"
shows "∀s ∈ pair ` setops⇩s⇩s⇩t (unlabel A). ∀t ∈ pair ` setops⇩s⇩s⇩t (unlabel A).
(∃σ θ ρ. wt⇩s⇩u⇩b⇩s⇩t σ ∧ wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range σ) ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧
Unifier ρ (s ⋅ σ) (t ⋅ θ))
⟶ (∃δ. Unifier δ s t)"
proof (intro ballI impI)
fix s t assume st: "s ∈ pair ` setops⇩s⇩s⇩t (unlabel A)" "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A)" and
"∃σ θ ρ. wt⇩s⇩u⇩b⇩s⇩t σ ∧ wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range σ) ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧
Unifier ρ (s ⋅ σ) (t ⋅ θ)"
then obtain σ θ ρ where σ:
"wt⇩s⇩u⇩b⇩s⇩t σ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range σ)" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
"Unifier ρ (s ⋅ σ) (t ⋅ θ)"
by moura
obtain fs ft cs ct where c:
"s = pair (cs, Fun (Set fs) [])" "t = pair (ct, Fun (Set ft) [])"
"Γ cs = TAtom Value" "Γ ct = TAtom Value"
using reachable_constraints_setops_form[OF A P st(1)]
reachable_constraints_setops_form[OF A P st(2)]
by moura
have "cs ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t A)" "ct ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t A)"
using c(1,2) setops_subterm_trms[OF st(1), of cs] setops_subterm_trms[OF st(2), of ct]
Fun_param_is_subterm[of cs "args s"] Fun_param_is_subterm[of ct "args t"]
unfolding pair_def by simp_all
moreover have
"∀T ∈ set P. wellformed_transaction T"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
using P unfolding admissible_transaction_def admissible_transaction_terms_def by fast+
ultimately have *: "wf⇩t⇩r⇩m cs" "wf⇩t⇩r⇩m ct"
using reachable_constraints_wf(2)[OF _ _ A] wf_trms_subterms by blast+
have "(∃x. cs = Var x) ∨ (∃c d. cs = Fun c [])"
using const_type_inv_wf c(3) *(1) by (cases cs) auto
moreover have "(∃x. ct = Var x) ∨ (∃c d. ct = Fun c [])"
using const_type_inv_wf c(4) *(2) by (cases ct) auto
ultimately show "∃δ. Unifier δ s t"
using reachable_constraints_setops_form[OF A P] reachable_constraints_setops_type[OF A P] st σ c
unfolding pair_def by auto
qed
lemma reachable_constraints_tfr:
assumes M:
"M ≡ ⋃T ∈ set P. trms_transaction T"
"has_all_wt_instances_of Γ M N"
"finite N"
"tfr⇩s⇩e⇩t N"
"wf⇩t⇩r⇩m⇩s N"
and P:
"∀T ∈ set P. admissible_transaction T"
"∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
and 𝒜: "𝒜 ∈ reachable_constraints P"
shows "tfr⇩s⇩s⇩t (unlabel 𝒜)"
using 𝒜
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step A T σ α)
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have P':
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s (trms_transaction T)"
using P(1) protocol_transaction_vars_TAtom_typed(3) admissible_transactions_wf⇩t⇩r⇩m⇩s
by blast+
have AT'_reach: "A@T' ∈ reachable_constraints P"
using reachable_constraints.step[OF step.hyps] unfolding T'_def by metis
have σα_wt: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using P'(1) step.hyps(2) transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
have σα_wf: "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
have σα_bvars_disj: "bvars⇩l⇩s⇩s⇩t (transaction_strand T) ∩ range_vars (σ ∘⇩s α) = {}"
by (rule transaction_fresh_subst_transaction_renaming_subst_vars_disj(4)[OF step.hyps(3,4,2)])
have wf_trms_M: "wf⇩t⇩r⇩m⇩s M"
using admissible_transactions_wf⇩t⇩r⇩m⇩s P(1)
unfolding M(1) by blast
have "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (A@T'))"
using reachable_constraints_SMP_subset(1)[OF AT'_reach P'(1)]
tfr_subset(3)[OF M(4), of "trms⇩l⇩s⇩s⇩t (A@T')"]
SMP_SMP_subset[of M N] SMP_I'[OF wf_trms_M M(5,2)]
unfolding M(1) by blast
moreover have "∀p. Ana (pair p) = ([],[])" unfolding pair_def by auto
ultimately have 1: "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (A@T') ∪ pair ` setops⇩s⇩s⇩t (unlabel (A@T')))"
using tfr_setops_if_tfr_trms[of "unlabel (A@T')"]
reachable_constraints_no_Pair_fun[OF AT'_reach P(1)]
reachable_constraints_setops_same_type_if_unifiable[OF AT'_reach P(1)]
reachable_constraints_setops_unfiable_if_wt_instance_unifiable[OF AT'_reach P(1)]
by blast
have "list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
using step.hyps(2) P(2) tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p
unfolding comp_tfr⇩s⇩s⇩t_def tfr⇩s⇩s⇩t_def by fastforce
hence "list_all tfr⇩s⇩s⇩t⇩p (unlabel T')"
using tfr⇩s⇩s⇩t⇩p_all_wt_subst_apply[OF _ σα_wt σα_wf σα_bvars_disj]
dual⇩l⇩s⇩s⇩t_tfr⇩s⇩s⇩t⇩p[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
unfolding T'_def by argo
hence 2: "list_all tfr⇩s⇩s⇩t⇩p (unlabel (A@T'))"
using step.IH unlabel_append
unfolding tfr⇩s⇩s⇩t_def by auto
have "tfr⇩s⇩s⇩t (unlabel (A@T'))" using 1 2 by (metis tfr⇩s⇩s⇩t_def)
thus ?case by (metis T'_def)
qed simp
lemma reachable_constraints_tfr':
assumes M:
"M ≡ ⋃T ∈ set P. trms_transaction T ∪ pair' Pair ` setops_transaction T"
"has_all_wt_instances_of Γ M N"
"finite N"
"tfr⇩s⇩e⇩t N"
"wf⇩t⇩r⇩m⇩s N"
and P:
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
"∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
and 𝒜: "𝒜 ∈ reachable_constraints P"
shows "tfr⇩s⇩s⇩t (unlabel 𝒜)"
using 𝒜
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step A T σ α)
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
have AT'_reach: "A@T' ∈ reachable_constraints P"
using reachable_constraints.step[OF step.hyps] unfolding T'_def by metis
have σα_wt: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using P(1) step.hyps(2) transaction_fresh_subst_transaction_renaming_wt[OF step.hyps(3,4)]
by fast
have σα_wf: "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
have σα_bvars_disj: "bvars⇩l⇩s⇩s⇩t (transaction_strand T) ∩ range_vars (σ ∘⇩s α) = {}"
by (rule transaction_fresh_subst_transaction_renaming_subst_vars_disj(4)[OF step.hyps(3,4,2)])
have wf_trms_M: "wf⇩t⇩r⇩m⇩s M"
using P(2) setops⇩s⇩s⇩t_wf⇩t⇩r⇩m⇩s(2) unfolding M(1) pair_code wf⇩t⇩r⇩m⇩s_code[symmetric] by fast
have "SMP (trms⇩l⇩s⇩s⇩t (A@T')) ⊆ SMP M" "SMP (pair ` setops⇩s⇩s⇩t (unlabel (A@T'))) ⊆ SMP M"
using reachable_constraints_SMP_subset[OF AT'_reach P(1)]
SMP_mono[of "⋃T ∈ set P. trms_transaction T" M]
SMP_mono[of "⋃T ∈ set P. pair ` setops_transaction T" M]
unfolding M(1) pair_code[symmetric] by blast+
hence 1: "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (A@T') ∪ pair ` setops⇩s⇩s⇩t (unlabel (A@T')))"
using tfr_subset(3)[OF M(4), of "trms⇩l⇩s⇩s⇩t (A@T') ∪ pair ` setops⇩s⇩s⇩t (unlabel (A@T'))"]
SMP_union[of "trms⇩l⇩s⇩s⇩t (A@T')" "pair ` setops⇩s⇩s⇩t (unlabel (A@T'))"]
SMP_SMP_subset[of M N] SMP_I'[OF wf_trms_M M(5,2)]
by blast
have "list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
using step.hyps(2) P(3) tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p
unfolding comp_tfr⇩s⇩s⇩t_def tfr⇩s⇩s⇩t_def by fastforce
hence "list_all tfr⇩s⇩s⇩t⇩p (unlabel T')"
using tfr⇩s⇩s⇩t⇩p_all_wt_subst_apply[OF _ σα_wt σα_wf σα_bvars_disj]
dual⇩l⇩s⇩s⇩t_tfr⇩s⇩s⇩t⇩p[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
unfolding T'_def by argo
hence 2: "list_all tfr⇩s⇩s⇩t⇩p (unlabel (A@T'))"
using step.IH unlabel_append
unfolding tfr⇩s⇩s⇩t_def by auto
have "tfr⇩s⇩s⇩t (unlabel (A@T'))" using 1 2 by (metis tfr⇩s⇩s⇩t_def)
thus ?case by (metis T'_def)
qed simp
lemma reachable_constraints_typing_cond⇩s⇩s⇩t:
assumes M:
"M ≡ ⋃T ∈ set P. trms_transaction T ∪ pair' Pair ` setops_transaction T"
"has_all_wt_instances_of Γ M N"
"finite N"
"tfr⇩s⇩e⇩t N"
"wf⇩t⇩r⇩m⇩s N"
and P:
"∀T ∈ set P. wellformed_transaction T"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
and 𝒜: "𝒜 ∈ reachable_constraints P"
shows "typing_cond⇩s⇩s⇩t (unlabel 𝒜)"
using reachable_constraints_wf[OF P(1,2) 𝒜] reachable_constraints_tfr'[OF M P(3,2,4) 𝒜]
unfolding typing_cond⇩s⇩s⇩t_def by blast
context
begin
private lemma reachable_constraints_par_comp⇩l⇩s⇩s⇩t_aux:
fixes P
defines "Ts ≡ concat (map transaction_strand P)"
assumes P_fresh_wf: "∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
(is "∀T ∈ set P. ?fresh_wf T")
and A: "A ∈ reachable_constraints P"
shows "∀b ∈ set (dual⇩l⇩s⇩s⇩t A). ∃a ∈ set Ts. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧
wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧
(∀t ∈ subst_range δ. (∃x. t = Var x) ∨ (∃c. t = Fun c []))"
(is "∀b ∈ set (dual⇩l⇩s⇩s⇩t A). ∃a ∈ set Ts. ?P b a")
using A
proof (induction A rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
define Q where "Q ≡ ?P"
define θ where "θ ≡ σ ∘⇩s α"
let ?R = "λA Ts. ∀b ∈ set A. ∃a ∈ set Ts. Q b a"
have T_fresh_wf: "?fresh_wf T" using step.hyps(2) P_fresh_wf by blast
have "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
"∀t ∈ subst_range θ. (∃x. t = Var x) ∨ (∃c. t = Fun c [])"
using wt_subst_compose[
OF transaction_fresh_subst_wt[OF step.hyps(3) T_fresh_wf]
transaction_renaming_subst_wt[OF step.hyps(4)]]
wf_trms_subst_compose[
OF transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]]
transaction_fresh_subst_transaction_renaming_subst_range'[OF step.hyps(3,4)]
unfolding θ_def by metis+
hence "?R (dual⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T)) ⋅⇩l⇩s⇩s⇩t θ) (transaction_strand T)"
using dual⇩l⇩s⇩s⇩t_self_inverse[of "transaction_strand T"]
by (auto simp add: Q_def subst_apply_labeled_stateful_strand_def)
hence "?R (dual⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) (transaction_strand T)"
by (metis dual⇩l⇩s⇩s⇩t_subst)
hence "?R (dual⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t θ))) Ts"
using step.hyps(2) unfolding Ts_def dual⇩l⇩s⇩s⇩t_def by fastforce
thus ?case using step.IH unfolding Q_def θ_def by auto
qed simp
lemma reachable_constraints_par_comp⇩l⇩s⇩s⇩t:
fixes P
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "Ts ≡ concat (map transaction_strand P)"
assumes P_pc: "comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair Ts M S"
and P_wf: "∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
and A: "A ∈ reachable_constraints P"
shows "par_comp⇩l⇩s⇩s⇩t A ((f (set S)) - {m. intruder_synth {} m})"
using par_comp⇩l⇩s⇩s⇩t_if_comp_par_comp⇩l⇩s⇩s⇩t'[OF P_pc, of "dual⇩l⇩s⇩s⇩t A", THEN par_comp⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t]
reachable_constraints_par_comp⇩l⇩s⇩s⇩t_aux[OF P_wf A, unfolded Ts_def[symmetric]]
unfolding f_def dual⇩l⇩s⇩s⇩t_self_inverse by fast
end
lemma reachable_constraints_par_comp_constr:
fixes P f S
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "Ts ≡ concat (map transaction_strand P)"
and "Sec ≡ (f (set S)) - {m. intruder_synth {} m}"
and "M ≡ ⋃T ∈ set P. trms_transaction T ∪ pair' Pair ` setops_transaction T"
assumes M:
"has_all_wt_instances_of Γ M N"
"finite N"
"tfr⇩s⇩e⇩t N"
"wf⇩t⇩r⇩m⇩s N"
and P:
"∀T ∈ set P. wellformed_transaction T"
"∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
"comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair Ts M_fun S"
and 𝒜: "𝒜 ∈ reachable_constraints P"
and ℐ: "constraint_model ℐ 𝒜"
shows "∃ℐ⇩τ. welltyped_constraint_model ℐ⇩τ 𝒜 ∧
((∀n. welltyped_constraint_model ℐ⇩τ (proj n 𝒜)) ∨
(∃𝒜'. prefix 𝒜' 𝒜 ∧ strand_leaks⇩l⇩s⇩s⇩t 𝒜' Sec ℐ⇩τ))"
proof -
have ℐ': "constr_sem_stateful ℐ (unlabel 𝒜)" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
using ℐ unfolding constraint_model_def by blast+
show ?thesis
using reachable_constraints_par_comp⇩l⇩s⇩s⇩t[OF P(5,3)[unfolded Ts_def] 𝒜]
reachable_constraints_typing_cond⇩s⇩s⇩t[OF M_def M P(1,2,3,4) 𝒜]
par_comp_constr_stateful[OF _ _ ℐ', of Sec]
unfolding f_def Sec_def welltyped_constraint_model_def constraint_model_def by blast
qed
end
end
Theory Term_Variants
section‹Term Variants›
theory Term_Variants
imports Stateful_Protocol_Composition_and_Typing.Intruder_Deduction
begin
fun term_variants where
"term_variants P (Var x) = [Var x]"
| "term_variants P (Fun f T) = (
let S = product_lists (map (term_variants P) T)
in map (Fun f) S@concat (map (λg. map (Fun g) S) (P f)))"
inductive term_variants_pred where
term_variants_Var:
"term_variants_pred P (Var x) (Var x)"
| term_variants_P:
"⟦length T = length S; ⋀i. i < length T ⟹ term_variants_pred P (T ! i) (S ! i); g ∈ set (P f)⟧
⟹ term_variants_pred P (Fun f T) (Fun g S)"
| term_variants_Fun:
"⟦length T = length S; ⋀i. i < length T ⟹ term_variants_pred P (T ! i) (S ! i)⟧
⟹ term_variants_pred P (Fun f T) (Fun f S)"
lemma term_variants_pred_inv:
assumes "term_variants_pred P (Fun f T) (Fun h S)"
shows "length T = length S"
and "⋀i. i < length T ⟹ term_variants_pred P (T ! i) (S ! i)"
and "f ≠ h ⟹ h ∈ set (P f)"
using assms by (auto elim: term_variants_pred.cases)
lemma term_variants_pred_inv':
assumes "term_variants_pred P (Fun f T) t"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ term_variants_pred P (T ! i) (args t ! i)"
and "f ≠ the_Fun t ⟹ the_Fun t ∈ set (P f)"
and "P ≡ (λ_. [])(g := [h]) ⟹ f ≠ the_Fun t ⟹ f = g ∧ the_Fun t = h"
using assms by (auto elim: term_variants_pred.cases)
lemma term_variants_pred_inv'':
assumes "term_variants_pred P t (Fun f T)"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ term_variants_pred P (args t ! i) (T ! i)"
and "f ≠ the_Fun t ⟹ f ∈ set (P (the_Fun t))"
and "P ≡ (λ_. [])(g := [h]) ⟹ f ≠ the_Fun t ⟹ f = h ∧ the_Fun t = g"
using assms by (auto elim: term_variants_pred.cases)
lemma term_variants_pred_inv_Var:
"term_variants_pred P (Var x) t ⟷ t = Var x"
"term_variants_pred P t (Var x) ⟷ t = Var x"
by (auto intro: term_variants_Var elim: term_variants_pred.cases)
lemma term_variants_pred_inv_const:
"term_variants_pred P (Fun c []) t ⟷ ((∃g ∈ set (P c). t = Fun g []) ∨ (t = Fun c []))"
by (auto intro: term_variants_P term_variants_Fun elim: term_variants_pred.cases)
lemma term_variants_pred_refl: "term_variants_pred P t t"
by (induct t) (auto intro: term_variants_pred.intros)
lemma term_variants_pred_refl_inv:
assumes st: "term_variants_pred P s t"
and P: "∀f. ∀g ∈ set (P f). f = g"
shows "s = t"
using st P
proof (induction s t rule: term_variants_pred.induct)
case (term_variants_Var P x) thus ?case by blast
next
case (term_variants_P T S P g f)
hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
hence "T = S" using term_variants_P.hyps(1) by (simp add: nth_equalityI)
thus ?case using term_variants_P.prems term_variants_P.hyps(3) by fast
next
case (term_variants_Fun T S P f)
hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
hence "T = S" using term_variants_Fun.hyps(1) by (simp add: nth_equalityI)
thus ?case by fast
qed
lemma term_variants_pred_const:
assumes "b ∈ set (P a)"
shows "term_variants_pred P (Fun a []) (Fun b [])"
using term_variants_P[of "[]" "[]"] assms by simp
lemma term_variants_pred_const_cases:
"P a ≠ [] ⟹ term_variants_pred P (Fun a []) t ⟷
(t = Fun a [] ∨ (∃b ∈ set (P a). t = Fun b []))"
"P a = [] ⟹ term_variants_pred P (Fun a []) t ⟷ t = Fun a []"
using term_variants_pred_inv_const[of P] by auto
lemma term_variants_pred_param:
assumes "term_variants_pred P t s"
and fg: "f = g ∨ g ∈ set (P f)"
shows "term_variants_pred P (Fun f (S@t#T)) (Fun g (S@s#T))"
proof -
have 1: "length (S@t#T) = length (S@s#T)" by simp
have "term_variants_pred P (T ! i) (T ! i)" "term_variants_pred P (S ! i) (S ! i)" for i
by (metis term_variants_pred_refl)+
hence 2: "term_variants_pred P ((S@t#T) ! i) ((S@s#T) ! i)" for i
by (simp add: assms nth_Cons' nth_append)
show ?thesis by (metis term_variants_Fun[OF 1 2] term_variants_P[OF 1 2] fg)
qed
lemma term_variants_pred_Cons:
assumes t: "term_variants_pred P t s"
and T: "term_variants_pred P (Fun f T) (Fun f S)"
and fg: "f = g ∨ g ∈ set (P f)"
shows "term_variants_pred P (Fun f (t#T)) (Fun g (s#S))"
proof -
have 1: "length (t#T) = length (s#S)"
and "⋀i. i < length T ⟹ term_variants_pred P (T ! i) (S ! i)"
using term_variants_pred_inv[OF T] by simp_all
hence 2: "⋀i. i < length (t#T) ⟹ term_variants_pred P ((t#T) ! i) ((s#S) ! i)"
by (metis t One_nat_def diff_less length_Cons less_Suc_eq less_imp_diff_less nth_Cons'
zero_less_Suc)
show ?thesis using 1 2 fg by (auto intro: term_variants_pred.intros)
qed
lemma term_variants_pred_dense:
fixes P Q::"'a set" and fs gs::"'a list"
defines "P_fs x ≡ if x ∈ P then fs else []"
and "P_gs x ≡ if x ∈ P then gs else []"
and "Q_fs x ≡ if x ∈ Q then fs else []"
assumes ut: "term_variants_pred P_fs u t"
and g: "g ∈ Q" "g ∈ set gs"
shows "∃s. term_variants_pred P_gs u s ∧ term_variants_pred Q_fs s t"
proof -
define F where "F ≡ λ(P::'a set) (fs::'a list) x. if x ∈ P then fs else []"
show ?thesis using ut g P_fs_def unfolding P_gs_def Q_fs_def
proof (induction P_fs u t arbitrary: g gs rule: term_variants_pred.induct)
case (term_variants_Var P h x) thus ?case
by (auto intro: term_variants_pred.term_variants_Var)
next
case (term_variants_P T S P' h' h g gs)
note hyps = term_variants_P.hyps(1,2,4,5,6,7)
note IH = term_variants_P.hyps(3)
have "∃s. term_variants_pred (F P gs) (T ! i) s ∧ term_variants_pred (F Q fs) s (S ! i)"
when i: "i < length T" for i
using IH[OF i hyps(4,5,6)] unfolding F_def by presburger
then obtain U where U:
"length T = length U" "⋀i. i < length T ⟹ term_variants_pred (F P gs) (T ! i) (U ! i)"
"length U = length S" "⋀i. i < length U ⟹ term_variants_pred (F Q fs) (U ! i) (S ! i)"
using hyps(1) Skolem_list_nth[of _ "λi s. term_variants_pred (F P gs) (T ! i) s ∧
term_variants_pred (F Q fs) s (S ! i)"]
by moura
show ?case
using term_variants_pred.term_variants_P[OF U(1,2), of g h]
term_variants_pred.term_variants_P[OF U(3,4), of h' g]
hyps(3)[unfolded hyps(6)] hyps(4,5)
unfolding F_def by force
next
case (term_variants_Fun T S P' h' g gs)
note hyps = term_variants_Fun.hyps(1,2,4,5,6)
note IH = term_variants_Fun.hyps(3)
have "∃s. term_variants_pred (F P gs) (T ! i) s ∧ term_variants_pred (F Q fs) s (S ! i)"
when i: "i < length T" for i
using IH[OF i hyps(3,4,5)] unfolding F_def by presburger
then obtain U where U:
"length T = length U" "⋀i. i < length T ⟹ term_variants_pred (F P gs) (T ! i) (U ! i)"
"length U = length S" "⋀i. i < length U ⟹ term_variants_pred (F Q fs) (U ! i) (S ! i)"
using hyps(1) Skolem_list_nth[of _ "λi s. term_variants_pred (F P gs) (T ! i) s ∧
term_variants_pred (F Q fs) s (S ! i)"]
by moura
thus ?case
using term_variants_pred.term_variants_Fun[OF U(1,2)]
term_variants_pred.term_variants_Fun[OF U(3,4)]
unfolding F_def by meson
qed
qed
lemma term_variants_pred_dense':
assumes ut: "term_variants_pred ((λ_. [])(a := [b])) u t"
shows "∃s. term_variants_pred ((λ_. [])(a := [c])) u s ∧
term_variants_pred ((λ_. [])(c := [b])) s t"
using ut term_variants_pred_dense[of "{a}" "[b]" u t c "{c}" "[c]"]
unfolding fun_upd_def by simp
lemma term_variants_pred_eq_case:
fixes t s::"('a,'b) term"
assumes "term_variants_pred P t s" "∀f ∈ funs_term t. P f = []"
shows "t = s"
using assms
proof (induction P t s rule: term_variants_pred.induct)
case (term_variants_Fun T S P f) thus ?case
using subtermeq_imp_funs_term_subset[OF Fun_param_in_subterms[OF nth_mem], of _ T f]
nth_equalityI[of T S]
by blast
qed (simp_all add: term_variants_pred_refl)
lemma term_variants_pred_subst:
assumes "term_variants_pred P t s"
shows "term_variants_pred P (t ⋅ δ) (s ⋅ δ)"
using assms
proof (induction P t s rule: term_variants_pred.induct)
case (term_variants_P T S P f g)
have 1: "length (map (λt. t ⋅ δ) T) = length (map (λt. t ⋅ δ) S)"
using term_variants_P.hyps
by simp
have 2: "term_variants_pred P ((map (λt. t ⋅ δ) T) ! i) ((map (λt. t ⋅ δ) S) ! i)"
when "i < length (map (λt. t ⋅ δ) T)" for i
using term_variants_P that
by fastforce
show ?case
using term_variants_pred.term_variants_P[OF 1 2 term_variants_P.hyps(3)]
by fastforce
next
case (term_variants_Fun T S P f)
have 1: "length (map (λt. t ⋅ δ) T) = length (map (λt. t ⋅ δ) S)"
using term_variants_Fun.hyps
by simp
have 2: "term_variants_pred P ((map (λt. t ⋅ δ) T) ! i) ((map (λt. t ⋅ δ) S) ! i)"
when "i < length (map (λt. t ⋅ δ) T)" for i
using term_variants_Fun that
by fastforce
show ?case
using term_variants_pred.term_variants_Fun[OF 1 2]
by fastforce
qed (simp add: term_variants_pred_refl)
lemma term_variants_pred_subst':
fixes t s::"('a,'b) term" and δ::"('a,'b) subst"
assumes "term_variants_pred P (t ⋅ δ) s"
and "∀x ∈ fv t ∪ fv s. (∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ P f = [])"
shows "∃u. term_variants_pred P t u ∧ s = u ⋅ δ"
using assms
proof (induction P "t ⋅ δ" s arbitrary: t rule: term_variants_pred.induct)
case (term_variants_Var P x g) thus ?case using term_variants_pred_refl by fast
next
case (term_variants_P T S P g f) show ?case
proof (cases t)
case (Var x) thus ?thesis
using term_variants_P.hyps(4,5) term_variants_P.prems
by fastforce
next
case (Fun h U)
hence 1: "h = f" "T = map (λs. s ⋅ δ) U" "length U = length T"
using term_variants_P.hyps(5) by simp_all
hence 2: "T ! i = U ! i ⋅ δ" when "i < length T" for i
using that by simp
have "∀x ∈ fv (U ! i) ∪ fv (S ! i). (∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ P f = [])"
when "i < length U" for i
using that Fun term_variants_P.prems term_variants_P.hyps(1) 1(3)
by force
hence IH: "∀i < length U. ∃u. term_variants_pred P (U ! i) u ∧ S ! i = u ⋅ δ"
by (metis 1(3) term_variants_P.hyps(3)[OF _ 2])
have "∃V. length U = length V ∧ S = map (λv. v ⋅ δ) V ∧
(∀i < length U. term_variants_pred P (U ! i) (V ! i))"
using term_variants_P.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
then obtain V where V: "length U = length V" "S = map (λv. v ⋅ δ) V"
"⋀i. i < length U ⟹ term_variants_pred P (U ! i) (V ! i)"
by moura
have "term_variants_pred P (Fun f U) (Fun g V)"
by (metis term_variants_pred.term_variants_P[OF V(1,3) term_variants_P.hyps(4)])
moreover have "Fun g S = Fun g V ⋅ δ" using V(2) by simp
ultimately show ?thesis using term_variants_P.hyps(1,4) Fun 1 by blast
qed
next
case (term_variants_Fun T S P f t) show ?case
proof (cases t)
case (Var x)
hence "T = []" "P f = []" using term_variants_Fun.hyps(4) term_variants_Fun.prems by fastforce+
thus ?thesis using term_variants_pred_refl Var term_variants_Fun.hyps(1,4) by fastforce
next
case (Fun h U)
hence 1: "h = f" "T = map (λs. s ⋅ δ) U" "length U = length T"
using term_variants_Fun.hyps(4) by simp_all
hence 2: "T ! i = U ! i ⋅ δ" when "i < length T" for i
using that by simp
have "∀x ∈ fv (U ! i) ∪ fv (S ! i). (∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ P f = [])"
when "i < length U" for i
using that Fun term_variants_Fun.prems term_variants_Fun.hyps(1) 1(3)
by force
hence IH: "∀i < length U. ∃u. term_variants_pred P (U ! i) u ∧ S ! i = u ⋅ δ"
by (metis 1(3) term_variants_Fun.hyps(3)[OF _ 2 ])
have "∃V. length U = length V ∧ S = map (λv. v ⋅ δ) V ∧
(∀i < length U. term_variants_pred P (U ! i) (V ! i))"
using term_variants_Fun.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
then obtain V where V: "length U = length V" "S = map (λv. v ⋅ δ) V"
"⋀i. i < length U ⟹ term_variants_pred P (U ! i) (V ! i)"
by moura
have "term_variants_pred P (Fun f U) (Fun f V)"
by (metis term_variants_pred.term_variants_Fun[OF V(1,3)])
moreover have "Fun f S = Fun f V ⋅ δ" using V(2) by simp
ultimately show ?thesis using term_variants_Fun.hyps(1) Fun 1 by blast
qed
qed
lemma term_variants_pred_iff_in_term_variants:
fixes t::"('a,'b) term"
shows "term_variants_pred P t s ⟷ s ∈ set (term_variants P t)"
(is "?A t s ⟷ ?B t s")
proof
define U where "U ≡ λP (T::('a,'b) term list). product_lists (map (term_variants P) T)"
have a:
"g ∈ set (P f) ⟹ set (map (Fun g) (U P T)) ⊆ set (term_variants P (Fun f T))"
"set (map (Fun f) (U P T)) ⊆ set (term_variants P (Fun f T))"
for f P g and T::"('a,'b) term list"
using term_variants.simps(2)[of P f T]
unfolding U_def Let_def by auto
have b: "∃S ∈ set (U P T). s = Fun f S ∨ (∃g ∈ set (P f). s = Fun g S)"
when "s ∈ set (term_variants P (Fun f T))" for P T f s
using that by (cases "P f") (auto simp add: U_def Let_def)
have c: "length T = length S" when "S ∈ set (U P T)" for S P T
using that unfolding U_def
by (simp add: in_set_product_lists_length)
show "?A t s ⟹ ?B t s"
proof (induction P t s rule: term_variants_pred.induct)
case (term_variants_P T S P g f)
note hyps = term_variants_P.hyps
note IH = term_variants_P.IH
have "S ∈ set (U P T)"
using IH hyps(1) product_lists_in_set_nth'[of _ S]
unfolding U_def by simp
thus ?case using a(1)[of _ P, OF hyps(3)] by auto
next
case (term_variants_Fun T S P f)
note hyps = term_variants_Fun.hyps
note IH = term_variants_Fun.IH
have "S ∈ set (U P T)"
using IH hyps(1) product_lists_in_set_nth'[of _ S]
unfolding U_def by simp
thus ?case using a(2)[of f P T] by (cases "P f") auto
qed (simp add: term_variants_Var)
show "?B t s ⟹ ?A t s"
proof (induction P t arbitrary: s rule: term_variants.induct)
case (2 P f T)
obtain S where S:
"s = Fun f S ∨ (∃g ∈ set (P f). s = Fun g S)"
"S ∈ set (U P T)" "length T = length S"
using c b[OF "2.prems"] by moura
have "∀i < length T. term_variants_pred P (T ! i) (S ! i)"
using "2.IH" S product_lists_in_set_nth by (fastforce simp add: U_def)
thus ?case using S by (auto intro: term_variants_pred.intros)
qed (simp add: term_variants_Var)
qed
lemma term_variants_pred_finite:
"finite {s. term_variants_pred P t s}"
using term_variants_pred_iff_in_term_variants[of P t]
by simp
lemma term_variants_pred_fv_eq:
assumes "term_variants_pred P s t"
shows "fv s = fv t"
using assms
by (induct rule: term_variants_pred.induct)
(metis, metis fv_eq_FunI, metis fv_eq_FunI)
lemma (in intruder_model) term_variants_pred_wf_trms:
assumes "term_variants_pred P s t"
and "⋀f g. g ∈ set (P f) ⟹ arity f = arity g"
and "wf⇩t⇩r⇩m s"
shows "wf⇩t⇩r⇩m t"
using assms
apply (induction rule: term_variants_pred.induct, simp)
by (metis (no_types) wf_trmI wf_trm_arity in_set_conv_nth wf_trm_param_idx)+
lemma term_variants_pred_funs_term:
assumes "term_variants_pred P s t"
and "f ∈ funs_term t"
shows "f ∈ funs_term s ∨ (∃g ∈ funs_term s. f ∈ set (P g))"
using assms
proof (induction rule: term_variants_pred.induct)
case (term_variants_P T S P g h) thus ?case
proof (cases "f = g")
case False
then obtain s where "s ∈ set S" "f ∈ funs_term s"
using funs_term_subterms_eq(1)[of "Fun g S"] term_variants_P.prems by auto
thus ?thesis
using term_variants_P.IH term_variants_P.hyps(1) in_set_conv_nth[of s S] by force
qed simp
next
case (term_variants_Fun T S P h) thus ?case
proof (cases "f = h")
case False
then obtain s where "s ∈ set S" "f ∈ funs_term s"
using funs_term_subterms_eq(1)[of "Fun h S"] term_variants_Fun.prems by auto
thus ?thesis
using term_variants_Fun.IH term_variants_Fun.hyps(1) in_set_conv_nth[of s S] by force
qed simp
qed fast
end
Theory Term_Implication
section‹Term Implication›
theory Term_Implication
imports Stateful_Protocol_Model Term_Variants
begin
subsection ‹Single Term Implications›
definition timpl_apply_term ("⟨_ --» _⟩⟨_⟩") where
"⟨a --» b⟩⟨t⟩ ≡ term_variants ((λ_. [])(Abs a := [Abs b])) t"
definition timpl_apply_terms ("⟨_ --» _⟩⟨_⟩⇩s⇩e⇩t") where
"⟨a --» b⟩⟨M⟩⇩s⇩e⇩t ≡ ⋃((set o timpl_apply_term a b) ` M)"
lemma timpl_apply_Fun:
assumes "⋀i. i < length T ⟹ S ! i ∈ set ⟨a --» b⟩⟨T ! i⟩"
and "length T = length S"
shows "Fun f S ∈ set ⟨a --» b⟩⟨Fun f T⟩"
using assms term_variants_Fun term_variants_pred_iff_in_term_variants
by (metis timpl_apply_term_def)
lemma timpl_apply_Abs:
assumes "⋀i. i < length T ⟹ S ! i ∈ set ⟨a --» b⟩⟨T ! i⟩"
and "length T = length S"
shows "Fun (Abs b) S ∈ set ⟨a --» b⟩⟨Fun (Abs a) T⟩"
using assms(1) term_variants_P[OF assms(2), of "(λ_. [])(Abs a := [Abs b])" "Abs b" "Abs a"]
unfolding timpl_apply_term_def term_variants_pred_iff_in_term_variants[symmetric]
by fastforce
lemma timpl_apply_refl: "t ∈ set ⟨a --» b⟩⟨t⟩"
unfolding timpl_apply_term_def
by (metis term_variants_pred_refl term_variants_pred_iff_in_term_variants)
lemma timpl_apply_const: "Fun (Abs b) [] ∈ set ⟨a --» b⟩⟨Fun (Abs a) []⟩"
using term_variants_pred_iff_in_term_variants term_variants_pred_const
unfolding timpl_apply_term_def by auto
lemma timpl_apply_const':
"c = a ⟹ set ⟨a --» b⟩⟨Fun (Abs c) []⟩ = {Fun (Abs b) [], Fun (Abs c) []}"
"c ≠ a ⟹ set ⟨a --» b⟩⟨Fun (Abs c) []⟩ = {Fun (Abs c) []}"
using term_variants_pred_const_cases[of "(λ_. [])(Abs a := [Abs b])" "Abs c"]
term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])"]
unfolding timpl_apply_term_def by auto
lemma timpl_apply_term_subst:
"s ∈ set ⟨a --» b⟩⟨t⟩ ⟹ s ⋅ δ ∈ set ⟨a --» b⟩⟨t ⋅ δ⟩"
by (metis term_variants_pred_iff_in_term_variants term_variants_pred_subst timpl_apply_term_def)
lemma timpl_apply_inv:
assumes "Fun h S ∈ set ⟨a --» b⟩⟨Fun f T⟩"
shows "length T = length S"
and "⋀i. i < length T ⟹ S ! i ∈ set ⟨a --» b⟩⟨T ! i⟩"
and "f ≠ h ⟹ f = Abs a ∧ h = Abs b"
using assms term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])"]
unfolding timpl_apply_term_def
by (metis (full_types) term_variants_pred_inv(1),
metis (full_types) term_variants_pred_inv(2),
fastforce dest: term_variants_pred_inv(3))
lemma timpl_apply_inv':
assumes "s ∈ set ⟨a --» b⟩⟨Fun f T⟩"
shows "∃g S. s = Fun g S"
proof -
have *: "term_variants_pred ((λ_. [])(Abs a := [Abs b])) (Fun f T) s"
using assms term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])"]
unfolding timpl_apply_term_def by force
show ?thesis using term_variants_pred.cases[OF *, of ?thesis] by fastforce
qed
lemma timpl_apply_term_Var_iff:
"Var x ∈ set ⟨a --» b⟩⟨t⟩ ⟷ t = Var x"
using term_variants_pred_inv_Var term_variants_pred_iff_in_term_variants
unfolding timpl_apply_term_def by metis
subsection ‹Term Implication Closure›
inductive_set timpl_closure for t TI where
FP: "t ∈ timpl_closure t TI"
| TI: "⟦u ∈ timpl_closure t TI; (a,b) ∈ TI; term_variants_pred ((λ_. [])(Abs a := [Abs b])) u s⟧
⟹ s ∈ timpl_closure t TI"
definition "timpl_closure_set M TI ≡ (⋃t ∈ M. timpl_closure t TI)"
inductive_set timpl_closure'_step for TI where
"⟦(a,b) ∈ TI; term_variants_pred ((λ_. [])(Abs a := [Abs b])) t s⟧
⟹ (t,s) ∈ timpl_closure'_step TI"
definition "timpl_closure' TI ≡ (timpl_closure'_step TI)⇧*"
definition comp_timpl_closure where
"comp_timpl_closure FP TI ≡
let f = λX. FP ∪ (⋃x ∈ X. ⋃(a,b) ∈ TI. set ⟨a --» b⟩⟨x⟩)
in while (λX. f X ≠ X) f {}"
definition comp_timpl_closure_list where
"comp_timpl_closure_list FP TI ≡
let f = λX. remdups (concat (map (λx. concat (map (λ(a,b). ⟨a --» b⟩⟨x⟩) TI)) X))
in while (λX. set (f X) ≠ set X) f FP"
lemma timpl_closure_setI:
"t ∈ M ⟹ t ∈ timpl_closure_set M TI"
unfolding timpl_closure_set_def by (auto intro: timpl_closure.FP)
lemma timpl_closure_set_empty_timpls:
"timpl_closure t {} = {t}" (is "?A = ?B")
proof (intro subset_antisym subsetI)
fix s show "s ∈ ?A ⟹ s ∈ ?B"
by (induct s rule: timpl_closure.induct) auto
qed (simp add: timpl_closure.FP)
lemmas timpl_closure_set_is_timpl_closure_union = meta_eq_to_obj_eq[OF timpl_closure_set_def]
lemma term_variants_pred_eq_case_Abs:
fixes a b
defines "P ≡ (λ_. [])(Abs a := [Abs b])"
assumes "term_variants_pred P t s" "∀f ∈ funs_term s. ¬is_Abs f"
shows "t = s"
using assms(2,3) P_def
proof (induction P t s rule: term_variants_pred.induct)
case (term_variants_Fun T S f)
have "¬is_Abs h" when i: "i < length S" and h: "h ∈ funs_term (S ! i)" for i h
using i h term_variants_Fun.hyps(4) by auto
hence "T ! i = S ! i" when i: "i < length T" for i using i term_variants_Fun.hyps(1,3) by auto
hence "T = S" using term_variants_Fun.hyps(1) nth_equalityI[of T S] by fast
thus ?case using term_variants_Fun.hyps(1) by blast
qed (simp_all add: term_variants_pred_refl)
lemma timpl_closure'_step_inv:
assumes "(t,s) ∈ timpl_closure'_step TI"
obtains a b where "(a,b) ∈ TI" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) t s"
using assms by (auto elim: timpl_closure'_step.cases)
lemma timpl_closure_mono:
assumes "TI ⊆ TI'"
shows "timpl_closure t TI ⊆ timpl_closure t TI'"
proof
fix s show "s ∈ timpl_closure t TI ⟹ s ∈ timpl_closure t TI'"
apply (induct rule: timpl_closure.induct)
using assms by (auto intro: timpl_closure.intros)
qed
lemma timpl_closure_set_mono:
assumes "M ⊆ M'" "TI ⊆ TI'"
shows "timpl_closure_set M TI ⊆ timpl_closure_set M' TI'"
using assms(1) timpl_closure_mono[OF assms(2)] unfolding timpl_closure_set_def by fast
lemma timpl_closure_idem:
"timpl_closure_set (timpl_closure t TI) TI = timpl_closure t TI" (is "?A = ?B")
proof
have "s ∈ timpl_closure t TI"
when "s ∈ timpl_closure u TI" "u ∈ timpl_closure t TI"
for s u
using that
by (induction rule: timpl_closure.induct)
(auto intro: timpl_closure.intros)
thus "?A ⊆ ?B" unfolding timpl_closure_set_def by blast
show "?B ⊆ ?A"
unfolding timpl_closure_set_def
by (blast intro: timpl_closure.FP)
qed
lemma timpl_closure_set_idem:
"timpl_closure_set (timpl_closure_set M TI) TI = timpl_closure_set M TI"
using timpl_closure_idem[of _ TI]unfolding timpl_closure_set_def by auto
lemma timpl_closure_set_mono_timpl_closure_set:
assumes N: "N ⊆ timpl_closure_set M TI"
shows "timpl_closure_set N TI ⊆ timpl_closure_set M TI"
using timpl_closure_set_mono[OF N, of TI TI] timpl_closure_set_idem[of M TI]
by simp
lemma timpl_closure_is_timpl_closure':
"s ∈ timpl_closure t TI ⟷ (t,s) ∈ timpl_closure' TI"
proof
show "s ∈ timpl_closure t TI ⟹ (t,s) ∈ timpl_closure' TI"
unfolding timpl_closure'_def
by (induct rule: timpl_closure.induct)
(auto intro: rtrancl_into_rtrancl timpl_closure'_step.intros)
show "(t,s) ∈ timpl_closure' TI ⟹ s ∈ timpl_closure t TI"
unfolding timpl_closure'_def
by (induct rule: rtrancl_induct)
(auto dest: timpl_closure'_step_inv
intro: timpl_closure.FP timpl_closure.TI)
qed
lemma timpl_closure'_mono:
assumes "TI ⊆ TI'"
shows "timpl_closure' TI ⊆ timpl_closure' TI'"
using timpl_closure_mono[OF assms]
timpl_closure_is_timpl_closure'[of _ _ TI]
timpl_closure_is_timpl_closure'[of _ _ TI']
by fast
lemma timpl_closureton_is_timpl_closure:
"timpl_closure_set {t} TI = timpl_closure t TI"
by (simp add: timpl_closure_set_is_timpl_closure_union)
lemma timpl_closure'_timpls_trancl_subset:
"timpl_closure' (c⇧+) ⊆ timpl_closure' c"
unfolding timpl_closure'_def
proof
fix s t::"(('a,'b,'c) prot_fun,'d) term"
show "(s,t) ∈ (timpl_closure'_step (c⇧+))⇧* ⟹ (s,t) ∈ (timpl_closure'_step c)⇧*"
proof (induction rule: rtrancl_induct)
case (step u t)
obtain a b where ab:
"(a,b) ∈ c⇧+" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u t"
using step.hyps(2) timpl_closure'_step_inv by blast
hence "(u,t) ∈ (timpl_closure'_step c)⇧*"
proof (induction arbitrary: t rule: trancl_induct)
case (step d e)
obtain s where s:
"term_variants_pred ((λ_. [])(Abs a := [Abs d])) u s"
"term_variants_pred ((λ_. [])(Abs d := [Abs e])) s t"
using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
have "(u,s) ∈ (timpl_closure'_step c)⇧*"
"(s,t) ∈ timpl_closure'_step c"
using step.hyps(2) s(2) step.IH[OF s(1)]
by (auto intro: timpl_closure'_step.intros)
thus ?case by simp
qed (auto intro: timpl_closure'_step.intros)
thus ?case using step.IH by simp
qed simp
qed
lemma timpl_closure'_timpls_trancl_subset':
"timpl_closure' {(a,b) ∈ c⇧+. a ≠ b} ⊆ timpl_closure' c"
using timpl_closure'_timpls_trancl_subset
timpl_closure'_mono[of "{(a,b) ∈ c⇧+. a ≠ b}" "c⇧+"]
by fast
lemma timpl_closure_set_timpls_trancl_subset:
"timpl_closure_set M (c⇧+) ⊆ timpl_closure_set M c"
using timpl_closure'_timpls_trancl_subset[of c]
timpl_closure_is_timpl_closure'[of _ _ c]
timpl_closure_is_timpl_closure'[of _ _ "c⇧+"]
timpl_closure_set_is_timpl_closure_union[of M c]
timpl_closure_set_is_timpl_closure_union[of M "c⇧+"]
by fastforce
lemma timpl_closure_set_timpls_trancl_subset':
"timpl_closure_set M {(a,b) ∈ c⇧+. a ≠ b} ⊆ timpl_closure_set M c"
using timpl_closure'_timpls_trancl_subset'[of c]
timpl_closure_is_timpl_closure'[of _ _ c]
timpl_closure_is_timpl_closure'[of _ _ "{(a,b) ∈ c⇧+. a ≠ b}"]
timpl_closure_set_is_timpl_closure_union[of M c]
timpl_closure_set_is_timpl_closure_union[of M "{(a,b) ∈ c⇧+. a ≠ b}"]
by fastforce
lemma timpl_closure'_timpls_trancl_supset':
"timpl_closure' c ⊆ timpl_closure' {(a,b) ∈ c⇧+. a ≠ b}"
unfolding timpl_closure'_def
proof
let ?cl = "{(a,b) ∈ c⇧+. a ≠ b}"
fix s t::"(('e,'f,'c) prot_fun,'g) term"
show "(s,t) ∈ (timpl_closure'_step c)⇧* ⟹ (s,t) ∈ (timpl_closure'_step ?cl)⇧*"
proof (induction rule: rtrancl_induct)
case (step u t)
obtain a b where ab:
"(a,b) ∈ c" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u t"
using step.hyps(2) timpl_closure'_step_inv by blast
hence "(a,b) ∈ c⇧+" by simp
hence "(u,t) ∈ (timpl_closure'_step ?cl)⇧*" using ab(2)
proof (induction arbitrary: t rule: trancl_induct)
case (base d) show ?case
proof (cases "a = d")
case True thus ?thesis
using base term_variants_pred_refl_inv[of _ u t]
by force
next
case False thus ?thesis
using base timpl_closure'_step.intros[of a d ?cl]
by fast
qed
next
case (step d e)
obtain s where s:
"term_variants_pred ((λ_. [])(Abs a := [Abs d])) u s"
"term_variants_pred ((λ_. [])(Abs d := [Abs e])) s t"
using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
show ?case
proof (cases "d = e")
case True
thus ?thesis
using step.prems step.IH[of t]
by blast
next
case False
hence "(u,s) ∈ (timpl_closure'_step ?cl)⇧*"
"(s,t) ∈ timpl_closure'_step ?cl"
using step.hyps(2) s(2) step.IH[OF s(1)]
by (auto intro: timpl_closure'_step.intros)
thus ?thesis by simp
qed
qed
thus ?case using step.IH by simp
qed simp
qed
lemma timpl_closure'_timpls_trancl_supset:
"timpl_closure' c ⊆ timpl_closure' (c⇧+)"
using timpl_closure'_timpls_trancl_supset'[of c]
timpl_closure'_mono[of "{(a,b) ∈ c⇧+. a ≠ b}" "c⇧+"]
by fast
lemma timpl_closure'_timpls_trancl_eq:
"timpl_closure' (c⇧+) = timpl_closure' c"
using timpl_closure'_timpls_trancl_subset timpl_closure'_timpls_trancl_supset
by blast
lemma timpl_closure'_timpls_trancl_eq':
"timpl_closure' {(a,b) ∈ c⇧+. a ≠ b} = timpl_closure' c"
using timpl_closure'_timpls_trancl_subset' timpl_closure'_timpls_trancl_supset'
by blast
lemma timpl_closure'_timpls_rtrancl_subset:
"timpl_closure' (c⇧*) ⊆ timpl_closure' c"
unfolding timpl_closure'_def
proof
fix s t::"(('a,'b,'c) prot_fun,'d) term"
show "(s,t) ∈ (timpl_closure'_step (c⇧*))⇧* ⟹ (s,t) ∈ (timpl_closure'_step c)⇧*"
proof (induction rule: rtrancl_induct)
case (step u t)
obtain a b where ab:
"(a,b) ∈ c⇧*" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u t"
using step.hyps(2) timpl_closure'_step_inv by blast
hence "(u,t) ∈ (timpl_closure'_step c)⇧*"
proof (induction arbitrary: t rule: rtrancl_induct)
case base
hence "u = t" using term_variants_pred_refl_inv by fastforce
thus ?case by simp
next
case (step d e)
obtain s where s:
"term_variants_pred ((λ_. [])(Abs a := [Abs d])) u s"
"term_variants_pred ((λ_. [])(Abs d := [Abs e])) s t"
using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
have "(u,s) ∈ (timpl_closure'_step c)⇧*"
"(s,t) ∈ timpl_closure'_step c"
using step.hyps(2) s(2) step.IH[OF s(1)]
by (auto intro: timpl_closure'_step.intros)
thus ?case by simp
qed
thus ?case using step.IH by simp
qed simp
qed
lemma timpl_closure'_timpls_rtrancl_supset:
"timpl_closure' c ⊆ timpl_closure' (c⇧*)"
unfolding timpl_closure'_def
proof
fix s t::"(('e,'f,'c) prot_fun,'g) term"
show "(s,t) ∈ (timpl_closure'_step c)⇧* ⟹ (s,t) ∈ (timpl_closure'_step (c⇧*))⇧*"
proof (induction rule: rtrancl_induct)
case (step u t)
obtain a b where ab:
"(a,b) ∈ c" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u t"
using step.hyps(2) timpl_closure'_step_inv by blast
hence "(a,b) ∈ c⇧*" by simp
hence "(u,t) ∈ (timpl_closure'_step (c⇧*))⇧*" using ab(2)
proof (induction arbitrary: t rule: rtrancl_induct)
case (base t) thus ?case using term_variants_pred_refl_inv[of _ u t] by fastforce
next
case (step d e)
obtain s where s:
"term_variants_pred ((λ_. [])(Abs a := [Abs d])) u s"
"term_variants_pred ((λ_. [])(Abs d := [Abs e])) s t"
using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
show ?case
proof (cases "d = e")
case True
thus ?thesis
using step.prems step.IH[of t]
by blast
next
case False
hence "(u,s) ∈ (timpl_closure'_step (c⇧*))⇧*"
"(s,t) ∈ timpl_closure'_step (c⇧*)"
using step.hyps(2) s(2) step.IH[OF s(1)]
by (auto intro: timpl_closure'_step.intros)
thus ?thesis by simp
qed
qed
thus ?case using step.IH by simp
qed simp
qed
lemma timpl_closure'_timpls_rtrancl_eq:
"timpl_closure' (c⇧*) = timpl_closure' c"
using timpl_closure'_timpls_rtrancl_subset timpl_closure'_timpls_rtrancl_supset
by blast
lemma timpl_closure_timpls_trancl_eq:
"timpl_closure t (c⇧+) = timpl_closure t c"
using timpl_closure'_timpls_trancl_eq[of c]
timpl_closure_is_timpl_closure'[of _ _ c]
timpl_closure_is_timpl_closure'[of _ _ "c⇧+"]
by fastforce
lemma timpl_closure_set_timpls_trancl_eq:
"timpl_closure_set M (c⇧+) = timpl_closure_set M c"
using timpl_closure_timpls_trancl_eq
timpl_closure_set_is_timpl_closure_union[of M c]
timpl_closure_set_is_timpl_closure_union[of M "c⇧+"]
by fastforce
lemma timpl_closure_set_timpls_trancl_eq':
"timpl_closure_set M {(a,b) ∈ c⇧+. a ≠ b} = timpl_closure_set M c"
using timpl_closure'_timpls_trancl_eq'[of c]
timpl_closure_is_timpl_closure'[of _ _ c]
timpl_closure_is_timpl_closure'[of _ _ "{(a,b) ∈ c⇧+. a ≠ b}"]
timpl_closure_set_is_timpl_closure_union[of M c]
timpl_closure_set_is_timpl_closure_union[of M "{(a,b) ∈ c⇧+. a ≠ b}"]
by fastforce
lemma timpl_closure_Var_in_iff:
"Var x ∈ timpl_closure t TI ⟷ t = Var x" (is "?A ⟷ ?B")
proof
have "s ∈ timpl_closure t TI ⟹ s = Var x ⟹ s = t" for s
apply (induction rule: timpl_closure.induct)
by (simp, metis term_variants_pred_inv_Var(2))
thus "?A ⟹ ?B" by blast
qed (blast intro: timpl_closure.FP)
lemma timpl_closure_set_Var_in_iff:
"Var x ∈ timpl_closure_set M TI ⟷ Var x ∈ M"
unfolding timpl_closure_set_def by (simp add: timpl_closure_Var_in_iff[of x _ TI])
lemma timpl_closure_Var_inv:
assumes "t ∈ timpl_closure (Var x) TI"
shows "t = Var x"
using assms
proof (induction rule: timpl_closure.induct)
case (TI u a b s) thus ?case using term_variants_pred_inv_Var by fast
qed simp
lemma timpls_Un_mono: "mono (λX. FP ∪ (⋃x ∈ X. ⋃(a,b) ∈ TI. set ⟨a --» b⟩⟨x⟩))"
by (auto intro!: monoI)
lemma timpl_closure_set_lfp:
fixes M TI
defines "f ≡ λX. M ∪ (⋃x ∈ X. ⋃(a,b) ∈ TI. set ⟨a --» b⟩⟨x⟩)"
shows "lfp f = timpl_closure_set M TI"
proof
note 0 = timpls_Un_mono[of M TI, unfolded f_def[symmetric]]
let ?N = "timpl_closure_set M TI"
show "lfp f ⊆ ?N"
proof (induction rule: lfp_induct)
case 2 thus ?case
proof
fix t assume "t ∈ f (lfp f ∩ ?N)"
hence "t ∈ M ∨ t ∈ (⋃x ∈ ?N. ⋃(a,b) ∈ TI. set ⟨a --» b⟩⟨x⟩)" (is "?A ∨ ?B")
unfolding f_def by blast
thus "t ∈ ?N"
proof
assume ?B
then obtain s a b where s: "s ∈ ?N" "(a,b) ∈ TI" "t ∈ set ⟨a --» b⟩⟨s⟩" by moura
thus ?thesis
using term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])" s]
unfolding timpl_closure_set_def timpl_apply_term_def
by (auto intro: timpl_closure.intros)
qed (auto simp add: timpl_closure_set_def intro: timpl_closure.intros)
qed
qed (rule 0)
have "t ∈ lfp f" when t: "t ∈ timpl_closure s TI" and s: "s ∈ M" for t s
using t
proof (induction t rule: timpl_closure.induct)
case (TI u a b v) thus ?case
using term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])"]
lfp_fixpoint[OF 0]
unfolding timpl_apply_term_def f_def by fastforce
qed (use s lfp_fixpoint[OF 0] f_def in blast)
thus "?N ⊆ lfp f" unfolding timpl_closure_set_def by blast
qed
lemma timpl_closure_set_supset:
assumes "∀t ∈ FP. t ∈ closure"
and "∀t ∈ closure. ∀(a,b) ∈ TI. ∀s ∈ set ⟨a --» b⟩⟨t⟩. s ∈ closure"
shows "timpl_closure_set FP TI ⊆ closure"
proof -
have "t ∈ closure" when t: "t ∈ timpl_closure s TI" and s: "s ∈ FP" for t s
using t
proof (induction rule: timpl_closure.induct)
case FP thus ?case using s assms(1) by blast
next
case (TI u a b s') thus ?case
using assms(2) term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs a := [Abs b])"]
unfolding timpl_apply_term_def by fastforce
qed
thus ?thesis unfolding timpl_closure_set_def by blast
qed
lemma timpl_closure_set_supset':
assumes "∀t ∈ FP. ∀(a,b) ∈ TI. ∀s ∈ set ⟨a --» b⟩⟨t⟩. s ∈ FP"
shows "timpl_closure_set FP TI ⊆ FP"
using timpl_closure_set_supset[OF _ assms] by blast
lemma timpl_closure'_param:
assumes "(t,s) ∈ timpl_closure' c"
and fg: "f = g ∨ (∃a b. (a,b) ∈ c ∧ f = Abs a ∧ g = Abs b)"
shows "(Fun f (S@t#T), Fun g (S@s#T)) ∈ timpl_closure' c"
using assms(1) unfolding timpl_closure'_def
proof (induction rule: rtrancl_induct)
case base thus ?case
proof (cases "f = g")
case False
then obtain a b where ab: "(a,b) ∈ c" "f = Abs a" "g = Abs b"
using fg by moura
show ?thesis
using term_variants_pred_param[OF term_variants_pred_refl[of "(λ_. [])(Abs a := [Abs b])" t]]
timpl_closure'_step.intros[OF ab(1)] ab(2,3)
by fastforce
qed simp
next
case (step u s)
obtain a b where ab: "(a,b) ∈ c" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u s"
using timpl_closure'_step_inv[OF step.hyps(2)] by blast
have "(Fun g (S@u#T), Fun g (S@s#T)) ∈ timpl_closure'_step c"
using ab(1) term_variants_pred_param[OF ab(2), of g g S T]
by (auto simp add: timpl_closure'_def intro: timpl_closure'_step.intros)
thus ?case using rtrancl_into_rtrancl[OF step.IH] fg by blast
qed
lemma timpl_closure'_param':
assumes "(t,s) ∈ timpl_closure' c"
shows "(Fun f (S@t#T), Fun f (S@s#T)) ∈ timpl_closure' c"
using timpl_closure'_param[OF assms] by simp
lemma timpl_closure_FunI:
assumes IH: "⋀i. i < length T ⟹ (T ! i, S ! i) ∈ timpl_closure' c"
and len: "length T = length S"
and fg: "f = g ∨ (∃a b. (a,b) ∈ c⇧+ ∧ f = Abs a ∧ g = Abs b)"
shows "(Fun f T, Fun g S) ∈ timpl_closure' c"
proof -
have aux: "(Fun f T, Fun g (take n S@drop n T)) ∈ timpl_closure' c"
when "n ≤ length T" for n
using that
proof (induction n)
case 0
have "(T ! n, T ! n) ∈ timpl_closure' c" when n: "n < length T" for n
using n unfolding timpl_closure'_def by simp
hence "(Fun f T, Fun g T) ∈ timpl_closure' c"
proof (cases "f = g")
case False
then obtain a b where ab: "(a, b) ∈ c⇧+" "f = Abs a" "g = Abs b"
using fg by moura
show ?thesis
using timpl_closure'_step.intros[OF ab(1), of "Fun f T" "Fun g T"] ab(2,3)
term_variants_P[OF _ term_variants_pred_refl[of "(λ_. [])(Abs a := [Abs b])"],
of T g f]
timpl_closure'_timpls_trancl_eq
unfolding timpl_closure'_def
by (metis fun_upd_same list.set_intros(1) r_into_rtrancl)
qed (simp add: timpl_closure'_def)
thus ?case by simp
next
case (Suc n)
hence IH': "(Fun f T, Fun g (take n S@drop n T)) ∈ timpl_closure' c"
and n: "n < length T" "n < length S"
by (simp_all add: len)
obtain T1 T2 where T: "T = T1@T ! n#T2" "length T1 = n"
using length_prefix_ex'[OF n(1)] by auto
obtain S1 S2 where S: "S = S1@S ! n#S2" "length S1 = n"
using length_prefix_ex'[OF n(2)] by auto
have "take n S@drop n T = S1@T ! n#T2" "take (Suc n) S@drop (Suc n) T = S1@S ! n#T2"
using n T S append_eq_conv_conj
by (metis, metis (no_types, hide_lams) Cons_nth_drop_Suc append.assoc append_Cons
append_Nil take_Suc_conv_app_nth)
moreover have "(T ! n, S ! n) ∈ timpl_closure' c" using IH Suc.prems by simp
ultimately show ?case
using timpl_closure'_param IH'(1)
by (metis (no_types, lifting) timpl_closure'_def rtrancl_trans)
qed
show ?thesis using aux[of "length T"] len by simp
qed
lemma timpl_closure_FunI':
assumes IH: "⋀i. i < length T ⟹ (T ! i, S ! i) ∈ timpl_closure' c"
and len: "length T = length S"
shows "(Fun f T, Fun f S) ∈ timpl_closure' c"
using timpl_closure_FunI[OF IH len] by simp
lemma timpl_closure_FunI2:
fixes f g::"('a, 'b, 'c) prot_fun"
assumes IH: "⋀i. i < length T ⟹ ∃u. (T!i, u) ∈ timpl_closure' c ∧ (S!i, u) ∈ timpl_closure' c"
and len: "length T = length S"
and fg: "f = g ∨ (∃a b d. (a, d) ∈ c⇧+ ∧ (b, d) ∈ c⇧+ ∧ f = Abs a ∧ g = Abs b)"
shows "∃h U. (Fun f T, Fun h U) ∈ timpl_closure' c ∧ (Fun g S, Fun h U) ∈ timpl_closure' c"
proof -
let ?P = "λi u. (T ! i, u) ∈ timpl_closure' c ∧ (S ! i, u) ∈ timpl_closure' c"
define U where "U ≡ map (λi. SOME u. ?P i u) [0..<length T]"
have U1: "length U = length T"
unfolding U_def by auto
have U2: "(T ! i, U ! i) ∈ timpl_closure' c ∧ (S ! i, U ! i) ∈ timpl_closure' c"
when i: "i < length U" for i
using i someI_ex[of "?P i"] IH[of i] U1 len
unfolding U_def by simp
show ?thesis
proof (cases "f = g")
case False
then obtain a b d where abd: "(a, d) ∈ c⇧+" "(b, d) ∈ c⇧+" "f = Abs a" "g = Abs b"
using fg by moura
define h::"('a, 'b, 'c) prot_fun" where "h = Abs d"
have "f = h ∨ (∃a b. (a, b) ∈ c⇧+ ∧ f = Abs a ∧ h = Abs b)"
"g = h ∨ (∃a b. (a, b) ∈ c⇧+ ∧ g = Abs a ∧ h = Abs b)"
using abd unfolding h_def by blast+
thus ?thesis by (metis timpl_closure_FunI len U1 U2)
qed (metis timpl_closure_FunI' len U1 U2)
qed
lemma timpl_closure_FunI3:
fixes f g::"('a, 'b, 'c) prot_fun"
assumes IH: "⋀i. i < length T ⟹ ∃u. (T!i, u) ∈ timpl_closure' c ∧ (S!i, u) ∈ timpl_closure' c"
and len: "length T = length S"
and fg: "f = g ∨ (∃a b d. (a, d) ∈ c ∧ (b, d) ∈ c ∧ f = Abs a ∧ g = Abs b)"
shows "∃h U. (Fun f T, Fun h U) ∈ timpl_closure' c ∧ (Fun g S, Fun h U) ∈ timpl_closure' c"
using timpl_closure_FunI2[OF IH len] fg unfolding timpl_closure'_timpls_trancl_eq by blast
lemma timpl_closure_fv_eq:
assumes "s ∈ timpl_closure t T"
shows "fv s = fv t"
using assms
by (induct rule: timpl_closure.induct)
(metis, metis term_variants_pred_fv_eq)
lemma (in stateful_protocol_model) timpl_closure_subst:
assumes t: "wf⇩t⇩r⇩m t" "∀x ∈ fv t. ∃a. Γ⇩v x = TAtom (Atom a)"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "timpl_closure (t ⋅ δ) T = timpl_closure t T ⋅⇩s⇩e⇩t δ"
proof
have "s ∈ timpl_closure t T ⋅⇩s⇩e⇩t δ"
when "s ∈ timpl_closure (t ⋅ δ) T" for s
using that
proof (induction s rule: timpl_closure.induct)
case FP thus ?case using timpl_closure.FP[of t T] by simp
next
case (TI u a b s)
then obtain u' where u': "u' ∈ timpl_closure t T" "u = u' ⋅ δ" by moura
have u'_fv: "∀x ∈ fv u'. ∃a. Γ⇩v x = TAtom (Atom a)"
using timpl_closure_fv_eq[OF u'(1)] t(2) by simp
hence u_fv: "∀x ∈ fv u. ∃a. Γ⇩v x = TAtom (Atom a)"
using u'(2) wt_subst_trm''[OF δ(1)] wt_subst_const_fv_type_eq[OF _ δ(1,2), of u']
by fastforce
have "∀x ∈ fv u' ∪ fv s. (∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ Abs a ≠ f)"
proof (intro ballI)
fix x assume x: "x ∈ fv u' ∪ fv s"
then obtain c where c: "Γ⇩v x = TAtom (Atom c)"
using u'_fv u_fv term_variants_pred_fv_eq[OF TI.hyps(3)]
by blast
show "(∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ Abs a ≠ f)"
proof (cases "δ x")
case (Fun f T)
hence **: "Γ (Fun f T) = TAtom (Atom c)" and "wf⇩t⇩r⇩m (Fun f T)"
using c wt_subst_trm''[OF δ(1), of "Var x"] δ(2)
by fastforce+
hence "δ x = Fun f []" using Fun const_type_inv_wf by metis
thus ?thesis using ** by force
qed metis
qed
hence *: "∀x ∈ fv u' ∪ fv s.
(∃y. δ x = Var y) ∨ (∃f. δ x = Fun f [] ∧ ((λ_. [])(Abs a := [Abs b])) f = [])"
by fastforce
obtain s' where s': "term_variants_pred ((λ_. [])(Abs a := [Abs b])) u' s'" "s = s' ⋅ δ"
using term_variants_pred_subst'[OF _ *] u'(2) TI.hyps(3)
by blast
show ?case using timpl_closure.TI[OF u'(1) TI.hyps(2) s'(1)] s'(2) by blast
qed
thus "timpl_closure (t ⋅ δ) T ⊆ timpl_closure t T ⋅⇩s⇩e⇩t δ" by fast
have "s ∈ timpl_closure (t ⋅ δ) T"
when s: "s ∈ timpl_closure t T ⋅⇩s⇩e⇩t δ" for s
proof -
obtain s' where s': "s' ∈ timpl_closure t T" "s = s' ⋅ δ" using s by moura
have "s' ⋅ δ ∈ timpl_closure (t ⋅ δ) T" using s'(1)
proof (induction s' rule: timpl_closure.induct)
case FP thus ?case using timpl_closure.FP[of "t ⋅ δ" T] by simp
next
case (TI u' a b s') show ?case
using timpl_closure.TI[OF TI.IH TI.hyps(2)]
term_variants_pred_subst[OF TI.hyps(3)]
by blast
qed
thus ?thesis using s'(2) by metis
qed
thus "timpl_closure t T ⋅⇩s⇩e⇩t δ ⊆ timpl_closure (t ⋅ δ) T" by fast
qed
lemma (in stateful_protocol_model) timpl_closure_subst_subset:
assumes t: "t ∈ M"
and M: "wf⇩t⇩r⇩m⇩s M" "∀x ∈ fv⇩s⇩e⇩t M. ∃a. Γ⇩v x = TAtom (Atom a)"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "ground (subst_range δ)" "subst_domain δ ⊆ fv⇩s⇩e⇩t M"
and M_supset: "timpl_closure t T ⊆ M"
shows "timpl_closure (t ⋅ δ) T ⊆ M ⋅⇩s⇩e⇩t δ"
proof -
have t': "wf⇩t⇩r⇩m t" "∀x ∈ fv t. ∃a. Γ⇩v x = TAtom (Atom a)" using t M by auto
show ?thesis using timpl_closure_subst[OF t' δ(1,2), of T] M_supset by blast
qed
lemma (in stateful_protocol_model) timpl_closure_set_subst_subset:
assumes M: "wf⇩t⇩r⇩m⇩s M" "∀x ∈ fv⇩s⇩e⇩t M. ∃a. Γ⇩v x = TAtom (Atom a)"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "ground (subst_range δ)" "subst_domain δ ⊆ fv⇩s⇩e⇩t M"
and M_supset: "timpl_closure_set M T ⊆ M"
shows "timpl_closure_set (M ⋅⇩s⇩e⇩t δ) T ⊆ M ⋅⇩s⇩e⇩t δ"
using timpl_closure_subst_subset[OF _ M δ, of _ T] M_supset
timpl_closure_set_is_timpl_closure_union[of "M ⋅⇩s⇩e⇩t δ" T]
timpl_closure_set_is_timpl_closure_union[of M T]
by auto
lemma timpl_closure_set_Union:
"timpl_closure_set (⋃Ms) T = (⋃M ∈ Ms. timpl_closure_set M T)"
using timpl_closure_set_is_timpl_closure_union[of "⋃Ms" T]
timpl_closure_set_is_timpl_closure_union[of _ T]
by force
lemma timpl_closure_set_Union_subst_set:
assumes "s ∈ timpl_closure_set (⋃{M ⋅⇩s⇩e⇩t δ | δ. P δ}) T"
shows "∃δ. P δ ∧ s ∈ timpl_closure_set (M ⋅⇩s⇩e⇩t δ) T"
using assms timpl_closure_set_is_timpl_closure_union[of "(⋃{M ⋅⇩s⇩e⇩t δ | δ. P δ})" T]
timpl_closure_set_is_timpl_closure_union[of _ T]
by blast
lemma timpl_closure_set_Union_subst_singleton:
assumes "s ∈ timpl_closure_set {t ⋅ δ | δ. P δ} T"
shows "∃δ. P δ ∧ s ∈ timpl_closure_set {t ⋅ δ} T"
using assms timpl_closure_set_is_timpl_closure_union[of "{t ⋅ δ |δ. P δ}" T]
timpl_closureton_is_timpl_closure[of _ T]
by fast
lemma timpl_closure'_inv:
assumes "(s, t) ∈ timpl_closure' TI"
shows "(∃x. s = Var x ∧ t = Var x) ∨ (∃f g S T. s = Fun f S ∧ t = Fun g T ∧ length S = length T)"
using assms unfolding timpl_closure'_def
proof (induction rule: rtrancl_induct)
case base thus ?case by (cases s) auto
next
case (step t u)
obtain a b where ab: "(a, b) ∈ TI" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) t u"
using timpl_closure'_step_inv[OF step.hyps(2)] by blast
show ?case using step.IH
proof
assume "∃x. s = Var x ∧ t = Var x"
thus ?case using step.hyps(2) term_variants_pred_inv_Var ab by fastforce
next
assume "∃f g S T. s = Fun f S ∧ t = Fun g T ∧ length S = length T"
then obtain f g S T where st: "s = Fun f S" "t = Fun g T" "length S = length T" by moura
thus ?case
using ab step.hyps(2) term_variants_pred_inv'[of "(λ_. [])(Abs a := [Abs b])" g T u]
by auto
qed
qed
lemma timpl_closure'_inv':
assumes "(s, t) ∈ timpl_closure' TI"
shows "(∃x. s = Var x ∧ t = Var x) ∨
(∃f g S T. s = Fun f S ∧ t = Fun g T ∧ length S = length T ∧
(∀i < length T. (S ! i, T ! i) ∈ timpl_closure' TI) ∧
(f ≠ g ⟶ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ TI⇧+))"
(is "?A s t ∨ ?B s t (timpl_closure' TI)")
using assms unfolding timpl_closure'_def
proof (induction rule: rtrancl_induct)
case base thus ?case by (cases s) auto
next
case (step t u)
obtain a b where ab: "(a, b) ∈ TI" "term_variants_pred ((λ_. [])(Abs a := [Abs b])) t u"
using timpl_closure'_step_inv[OF step.hyps(2)] by blast
show ?case using step.IH
proof
assume "?A s t"
thus ?case using step.hyps(2) term_variants_pred_inv_Var ab by fastforce
next
assume "?B s t ((timpl_closure'_step TI)⇧*)"
then obtain f g S T where st:
"s = Fun f S" "t = Fun g T" "length S = length T"
"⋀i. i < length T ⟹ (S ! i, T ! i) ∈ (timpl_closure'_step TI)⇧*"
"f ≠ g ⟹ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ TI⇧+"
by moura
obtain h U where u:
"u = Fun h U" "length T = length U"
"⋀i. i < length T ⟹ term_variants_pred ((λ_. [])(Abs a := [Abs b])) (T ! i) (U ! i)"
"g ≠ h ⟹ is_Abs g ∧ is_Abs h ∧ (the_Abs g, the_Abs h) ∈ TI⇧+"
using ab(2) st(2) r_into_trancl[OF ab(1)]
term_variants_pred_inv'(1,2,3,4)[of "(λ_. [])(Abs a := [Abs b])" g T u]
term_variants_pred_inv'(5)[of "(λ_. [])(Abs a := [Abs b])" g T u "Abs a" "Abs b"]
unfolding is_Abs_def the_Abs_def by force
have "(S ! i, U ! i) ∈ (timpl_closure'_step TI)⇧*" when i: "i < length U" for i
using u(2) i rtrancl.rtrancl_into_rtrancl[OF
st(4)[of i] timpl_closure'_step.intros[OF ab(1) u(3)[of i]]]
by argo
moreover have "length S = length U" using st u by argo
moreover have "is_Abs f ∧ is_Abs h ∧ (the_Abs f, the_Abs h) ∈ TI⇧+" when fh: "f ≠ h"
using fh st u by fastforce
ultimately show ?case using st(1) u(1) by blast
qed
qed
lemma timpl_closure'_inv'':
assumes "(Fun f S, Fun g T) ∈ timpl_closure' TI"
shows "length S = length T"
and "⋀i. i < length T ⟹ (S ! i, T ! i) ∈ timpl_closure' TI"
and "f ≠ g ⟹ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ TI⇧+"
using assms timpl_closure'_inv' by auto
lemma timpl_closure_Fun_inv:
assumes "s ∈ timpl_closure (Fun f T) TI"
shows "∃g S. s = Fun g S"
using assms timpl_closure_is_timpl_closure' timpl_closure'_inv
by fastforce
lemma timpl_closure_Fun_inv':
assumes "Fun g S ∈ timpl_closure (Fun f T) TI"
shows "length S = length T"
and "⋀i. i < length S ⟹ S ! i ∈ timpl_closure (T ! i) TI"
and "f ≠ g ⟹ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ TI⇧+"
using assms timpl_closure_is_timpl_closure'
by (metis timpl_closure'_inv''(1), metis timpl_closure'_inv''(2), metis timpl_closure'_inv''(3))
lemma timpl_closure_Fun_not_Var[simp]:
"Fun f T ∉ timpl_closure (Var x) TI"
using timpl_closure_Var_inv by fast
lemma timpl_closure_Var_not_Fun[simp]:
"Var x ∉ timpl_closure (Fun f T) TI"
using timpl_closure_Fun_inv by fast
lemma (in stateful_protocol_model) timpl_closure_wf_trms:
assumes m: "wf⇩t⇩r⇩m m"
shows "wf⇩t⇩r⇩m⇩s (timpl_closure m TI)"
proof
fix t assume "t ∈ timpl_closure m TI"
thus "wf⇩t⇩r⇩m t"
proof (induction t rule: timpl_closure.induct)
case TI thus ?case using term_variants_pred_wf_trms by force
qed (rule m)
qed
lemma (in stateful_protocol_model) timpl_closure_set_wf_trms:
assumes M: "wf⇩t⇩r⇩m⇩s M"
shows "wf⇩t⇩r⇩m⇩s (timpl_closure_set M TI)"
proof
fix t assume "t ∈ timpl_closure_set M TI"
then obtain m where "t ∈ timpl_closure m TI" "m ∈ M" "wf⇩t⇩r⇩m m"
using M timpl_closure_set_is_timpl_closure_union by blast
thus "wf⇩t⇩r⇩m t" using timpl_closure_wf_trms by blast
qed
lemma timpl_closure_Fu_inv:
assumes "t ∈ timpl_closure (Fun (Fu f) T) TI"
shows "∃S. length S = length T ∧ t = Fun (Fu f) S"
using assms
proof (induction t rule: timpl_closure.induct)
case (TI u a b s)
then obtain U where U: "length U = length T" "u = Fun (Fu f) U"
by moura
hence *: "term_variants_pred ((λ_. [])(Abs a := [Abs b])) (Fun (Fu f) U) s"
using TI.hyps(3) by meson
show ?case
using term_variants_pred_inv'(1,2,4)[OF *] U
by force
qed simp
lemma timpl_closure_Fu_inv':
assumes "Fun (Fu f) T ∈ timpl_closure t TI"
shows "∃S. length S = length T ∧ t = Fun (Fu f) S"
using assms
proof (induction "Fun (Fu f) T" arbitrary: T rule: timpl_closure.induct)
case (TI u a b)
obtain g U where U:
"u = Fun g U" "length U = length T"
"Fu f ≠ g ⟹ Abs a = g ∧ Fu f = Abs b"
using term_variants_pred_inv''[OF TI.hyps(4)] by fastforce
have g: "g = Fu f" using U(3) by blast
show ?case using TI.hyps(2)[OF U(1)[unfolded g]] U(2) by auto
qed simp
lemma timpl_closure_no_Abs_eq:
assumes "t ∈ timpl_closure s TI"
and "∀f ∈ funs_term t. ¬is_Abs f"
shows "t = s"
using assms
proof (induction t rule: timpl_closure.induct)
case (TI t a b s) thus ?case
using term_variants_pred_eq_case_Abs[of a b t s]
unfolding timpl_apply_term_def term_variants_pred_iff_in_term_variants[symmetric]
by metis
qed simp
lemma timpl_closure_set_no_Abs_in_set:
assumes "t ∈ timpl_closure_set FP TI"
and "∀f ∈ funs_term t. ¬is_Abs f"
shows "t ∈ FP"
using assms timpl_closure_no_Abs_eq unfolding timpl_closure_set_def by blast
lemma timpl_closure_funs_term_subset:
"⋃(funs_term ` (timpl_closure t TI)) ⊆ funs_term t ∪ Abs ` snd ` TI"
(is "?A ⊆ ?B ∪ ?C")
proof
fix f assume "f ∈ ?A"
then obtain s where "s ∈ timpl_closure t TI" "f ∈ funs_term s" by moura
thus "f ∈ ?B ∪ ?C"
proof (induction s rule: timpl_closure.induct)
case (TI u a b s)
have "Abs b ∈ Abs ` snd ` TI" using TI.hyps(2) by force
thus ?case using term_variants_pred_funs_term[OF TI.hyps(3) TI.prems] TI.IH by force
qed blast
qed
lemma timpl_closure_set_funs_term_subset:
"⋃(funs_term ` (timpl_closure_set FP TI)) ⊆ ⋃(funs_term ` FP) ∪ Abs ` snd ` TI"
using timpl_closure_funs_term_subset[of _ TI]
timpl_closure_set_is_timpl_closure_union[of FP TI]
by auto
lemma funs_term_OCC_TI_subset:
defines "absc ≡ λa. Fun (Abs a) []"
assumes OCC1: "∀t ∈ FP. ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` OCC"
and OCC2: "snd ` TI ⊆ OCC"
shows "∀t ∈ timpl_closure_set FP TI. ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` OCC" (is ?A)
and "∀t ∈ absc ` OCC. ∀(a,b) ∈ TI. ∀s ∈ set ⟨a --» b⟩⟨t⟩. s ∈ absc ` OCC" (is ?B)
proof -
let ?F = "⋃(funs_term ` FP)"
let ?G = "Abs ` snd ` TI"
show ?A
proof (intro ballI impI)
fix t f assume t: "t ∈ timpl_closure_set FP TI" and f: "f ∈ funs_term t" "is_Abs f"
hence "f ∈ ?F ∨ f ∈ ?G" using timpl_closure_set_funs_term_subset[of FP TI] by auto
thus "f ∈ Abs ` OCC"
proof
assume "f ∈ ?F" thus ?thesis using OCC1 f(2) by fast
next
assume "f ∈ ?G" thus ?thesis using OCC2 by auto
qed
qed
{ fix s t a b
assume t: "t ∈ absc ` OCC"
and ab: "(a, b) ∈ TI"
and s: "s ∈ set ⟨a --» b⟩⟨t⟩"
obtain c where c: "t = absc c" "c ∈ OCC" using t by moura
hence "s = absc b ∨ s = absc c"
using ab s timpl_apply_const'[of c a b] unfolding absc_def by auto
moreover have "b ∈ OCC" using ab OCC2 by auto
ultimately have "s ∈ absc ` OCC" using c(2) by blast
} thus ?B by blast
qed
lemma (in stateful_protocol_model) intruder_synth_timpl_closure_set:
fixes M::"('fun,'atom,'sets) prot_terms" and t::"('fun,'atom,'sets) prot_term"
assumes "M ⊢⇩c t"
and "s ∈ timpl_closure t TI"
shows "timpl_closure_set M TI ⊢⇩c s"
using assms
proof (induction t arbitrary: s rule: intruder_synth_induct)
case (AxiomC t)
hence "s ∈ timpl_closure_set M TI"
using timpl_closure_set_is_timpl_closure_union[of M TI]
by blast
thus ?case by simp
next
case (ComposeC T f)
obtain g S where s: "s = Fun g S"
using timpl_closure_Fun_inv[OF ComposeC.prems] by moura
hence s':
"f = g" "length S = length T"
"⋀i. i < length S ⟹ S ! i ∈ timpl_closure (T ! i) TI"
using timpl_closure_Fun_inv'[of g S f T TI] ComposeC.prems ComposeC.hyps(2)
unfolding is_Abs_def by fastforce+
have "timpl_closure_set M TI ⊢⇩c u" when u: "u ∈ set S" for u
using ComposeC.IH u s'(2,3) in_set_conv_nth[of _ T] in_set_conv_nth[of u S] by auto
thus ?case
using s s'(1,2) ComposeC.hyps(1,2) intruder_synth.ComposeC[of S g "timpl_closure_set M TI"]
by argo
qed
lemma (in stateful_protocol_model) intruder_synth_timpl_closure':
fixes M::"('fun,'atom,'sets) prot_terms" and t::"('fun,'atom,'sets) prot_term"
assumes "timpl_closure_set M TI ⊢⇩c t"
and "s ∈ timpl_closure t TI"
shows "timpl_closure_set M TI ⊢⇩c s"
by (metis intruder_synth_timpl_closure_set[OF assms] timpl_closure_set_idem)
lemma timpl_closure_set_absc_subset_in:
defines "absc ≡ λa. Fun (Abs a) []"
assumes A: "timpl_closure_set (absc ` A) TI ⊆ absc ` A"
and a: "a ∈ A" "(a,b) ∈ TI⇧+"
shows "b ∈ A"
proof -
have "timpl_closure (absc a) (TI⇧+) ⊆ absc ` A"
using a(1) A timpl_closure_timpls_trancl_eq
unfolding timpl_closure_set_def by fast
thus ?thesis
using timpl_closure.TI[OF timpl_closure.FP[of "absc a"] a(2), of "absc b"]
term_variants_P[of "[]" "[]" "(λ_. [])(Abs a := [Abs b])" "Abs b" "Abs a"]
unfolding absc_def by auto
qed
subsection ‹Composition-only Intruder Deduction Modulo Term Implication Closure of the Intruder Knowledge›
context stateful_protocol_model
begin
fun in_trancl where
"in_trancl TI a b = (
if (a,b) ∈ set TI then True
else list_ex (λ(c,d). c = a ∧ in_trancl (removeAll (c,d) TI) d b) TI)"
definition in_rtrancl where
"in_rtrancl TI a b ≡ a = b ∨ in_trancl TI a b"
declare in_trancl.simps[simp del]
fun timpls_transformable_to where
"timpls_transformable_to TI (Var x) (Var y) = (x = y)"
| "timpls_transformable_to TI (Fun f T) (Fun g S) = (
(f = g ∨ (is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set TI)) ∧
list_all2 (timpls_transformable_to TI) T S)"
| "timpls_transformable_to _ _ _ = False"
fun timpls_transformable_to' where
"timpls_transformable_to' TI (Var x) (Var y) = (x = y)"
| "timpls_transformable_to' TI (Fun f T) (Fun g S) = (
(f = g ∨ (is_Abs f ∧ is_Abs g ∧ in_trancl TI (the_Abs f) (the_Abs g))) ∧
list_all2 (timpls_transformable_to' TI) T S)"
| "timpls_transformable_to' _ _ _ = False"
fun equal_mod_timpls where
"equal_mod_timpls TI (Var x) (Var y) = (x = y)"
| "equal_mod_timpls TI (Fun f T) (Fun g S) = (
(f = g ∨ (is_Abs f ∧ is_Abs g ∧
((the_Abs f, the_Abs g) ∈ set TI ∨
(the_Abs g, the_Abs f) ∈ set TI ∨
(∃ti ∈ set TI. (the_Abs f, snd ti) ∈ set TI ∧ (the_Abs g, snd ti) ∈ set TI)))) ∧
list_all2 (equal_mod_timpls TI) T S)"
| "equal_mod_timpls _ _ _ = False"
fun intruder_synth_mod_timpls where
"intruder_synth_mod_timpls M TI (Var x) = List.member M (Var x)"
| "intruder_synth_mod_timpls M TI (Fun f T) = (
(list_ex (λt. timpls_transformable_to TI t (Fun f T)) M) ∨
(public f ∧ length T = arity f ∧ list_all (intruder_synth_mod_timpls M TI) T))"
fun intruder_synth_mod_timpls' where
"intruder_synth_mod_timpls' M TI (Var x) = List.member M (Var x)"
| "intruder_synth_mod_timpls' M TI (Fun f T) = (
(list_ex (λt. timpls_transformable_to' TI t (Fun f T)) M) ∨
(public f ∧ length T = arity f ∧ list_all (intruder_synth_mod_timpls' M TI) T))"
fun intruder_synth_mod_eq_timpls where
"intruder_synth_mod_eq_timpls M TI (Var x) = (Var x ∈ M)"
| "intruder_synth_mod_eq_timpls M TI (Fun f T) = (
(∃t ∈ M. equal_mod_timpls TI t (Fun f T)) ∨
(public f ∧ length T = arity f ∧ list_all (intruder_synth_mod_eq_timpls M TI) T))"
definition analyzed_closed_mod_timpls where
"analyzed_closed_mod_timpls M TI ≡
let f = list_all (intruder_synth_mod_timpls M TI);
g = λt. if f (fst (Ana t)) then f (snd (Ana t))
else ∀s ∈ comp_timpl_closure {t} (set TI). case Ana s of (K,R) ⇒ f K ⟶ f R
in list_all g M"
definition analyzed_closed_mod_timpls' where
"analyzed_closed_mod_timpls' M TI ≡
let f = list_all (intruder_synth_mod_timpls' M TI);
g = λt. if f (fst (Ana t)) then f (snd (Ana t))
else ∀s ∈ comp_timpl_closure {t} (set TI). case Ana s of (K,R) ⇒ f K ⟶ f R
in list_all g M"
definition analyzed_closed_mod_timpls_alt where
"analyzed_closed_mod_timpls_alt M TI timpl_cl_witness ≡
let f = λR. ∀r ∈ set R. intruder_synth_mod_timpls M TI r;
N = {t ∈ set M. f (fst (Ana t))};
N' = set M - N
in (∀t ∈ N. f (snd (Ana t))) ∧
(N' ≠ {} ⟶ (N' ∪ (⋃x∈timpl_cl_witness. ⋃(a,b)∈set TI. set ⟨a --» b⟩⟨x⟩) ⊆ timpl_cl_witness)) ∧
(∀s ∈ timpl_cl_witness. case Ana s of (K,R) ⇒ f K ⟶ f R)"
lemma in_trancl_closure_iff_in_trancl_fun:
"(a,b) ∈ (set TI)⇧+ ⟷ in_trancl TI a b" (is "?A TI a b ⟷ ?B TI a b")
proof
show "?A TI a b ⟹ ?B TI a b"
proof (induction rule: trancl_induct)
case (step c d)
show ?case using step.IH step.hyps(2)
proof (induction TI a c rule: in_trancl.induct)
case (1 TI a b) thus ?case using in_trancl.simps
by (smt Bex_set case_prodE case_prodI member_remove prod.sel(2) remove_code(1))
qed
qed (metis in_trancl.simps)
show "?B TI a b ⟹ ?A TI a b"
proof (induction TI a b rule: in_trancl.induct)
case (1 TI a b)
let ?P = "λTI a b c d. in_trancl (List.removeAll (c,d) TI) d b"
have *: "∃(c,d) ∈ set TI. c = a ∧ ?P TI a b c d" when "(a,b) ∉ set TI"
using that "1.prems" list_ex_iff[of _ TI] in_trancl.simps[of TI a b]
by auto
show ?case
proof (cases "(a,b) ∈ set TI")
case False
hence "∃(c,d) ∈ set TI. c = a ∧ ?P TI a b c d" using * by blast
then obtain d where d: "(a,d) ∈ set TI" "?P TI a b a d" by blast
have "(d,b) ∈ (set (removeAll (a,d) TI))⇧+" using "1.IH"[OF False d(1)] d(2) by blast
moreover have "set (removeAll (a,d) TI) ⊆ set TI" by simp
ultimately have "(d,b) ∈ (set TI)⇧+" using trancl_mono by blast
thus ?thesis using d(1) by fastforce
qed simp
qed
qed
lemma in_rtrancl_closure_iff_in_rtrancl_fun:
"(a,b) ∈ (set TI)⇧* ⟷ in_rtrancl TI a b"
by (metis rtrancl_eq_or_trancl in_trancl_closure_iff_in_trancl_fun in_rtrancl_def)
lemma in_trancl_mono:
assumes "set TI ⊆ set TI'"
and "in_trancl TI a b"
shows "in_trancl TI' a b"
by (metis assms in_trancl_closure_iff_in_trancl_fun trancl_mono)
lemma equal_mod_timpls_refl:
"equal_mod_timpls TI t t"
proof (induction t)
case (Fun f T) thus ?case
using list_all2_conv_all_nth[of "equal_mod_timpls TI" T T] by force
qed simp
lemma equal_mod_timpls_inv_Var:
"equal_mod_timpls TI (Var x) t ⟹ t = Var x" (is "?A ⟹ ?C")
"equal_mod_timpls TI t (Var x) ⟹ t = Var x" (is "?B ⟹ ?C")
proof -
show "?A ⟹ ?C" by (cases t) auto
show "?B ⟹ ?C" by (cases t) auto
qed
lemma equal_mod_timpls_inv:
assumes "equal_mod_timpls TI (Fun f T) (Fun g S)"
shows "length T = length S"
and "⋀i. i < length T ⟹ equal_mod_timpls TI (T ! i) (S ! i)"
and "f ≠ g ⟹ (is_Abs f ∧ is_Abs g ∧ (
(the_Abs f, the_Abs g) ∈ set TI ∨ (the_Abs g, the_Abs f) ∈ set TI ∨
(∃ti ∈ set TI. (the_Abs f, snd ti) ∈ set TI ∧
(the_Abs g, snd ti) ∈ set TI)))"
using assms list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
by (auto elim: equal_mod_timpls.cases)
lemma equal_mod_timpls_inv':
assumes "equal_mod_timpls TI (Fun f T) t"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ equal_mod_timpls TI (T ! i) (args t ! i)"
and "f ≠ the_Fun t ⟹ (is_Abs f ∧ is_Abs (the_Fun t) ∧ (
(the_Abs f, the_Abs (the_Fun t)) ∈ set TI ∨
(the_Abs (the_Fun t), the_Abs f) ∈ set TI ∨
(∃ti ∈ set TI. (the_Abs f, snd ti) ∈ set TI ∧
(the_Abs (the_Fun t), snd ti) ∈ set TI)))"
and "¬is_Abs f ⟹ f = the_Fun t"
using assms list_all2_conv_all_nth[of "equal_mod_timpls TI" T]
by (cases t; auto)+
lemma equal_mod_timpls_if_term_variants:
fixes s t::"(('a, 'b, 'c) prot_fun, 'd) term" and a b::"'c set"
defines "P ≡ (λ_. [])(Abs a := [Abs b])"
assumes st: "term_variants_pred P s t"
and ab: "(a,b) ∈ set TI"
shows "equal_mod_timpls TI s t"
using st P_def
proof (induction rule: term_variants_pred.induct)
case (term_variants_P T S f) thus ?case
using ab list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
by auto
next
case (term_variants_Fun T S f) thus ?case
using ab list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
by auto
qed simp
lemma equal_mod_timpls_mono:
assumes "set TI ⊆ set TI'"
and "equal_mod_timpls TI s t"
shows "equal_mod_timpls TI' s t"
using assms
proof (induction TI s t rule: equal_mod_timpls.induct)
case (2 TI f T g S)
have *: "f = g ∨ (is_Abs f ∧ is_Abs g ∧ ((the_Abs f, the_Abs g) ∈ set TI ∨
(the_Abs g, the_Abs f) ∈ set TI ∨
(∃ti ∈ set TI. (the_Abs f, snd ti) ∈ set TI ∧
(the_Abs g, snd ti) ∈ set TI)))"
"list_all2 (equal_mod_timpls TI) T S"
using "2.prems" by simp_all
show ?case
using "2.IH" "2.prems"(1) list.rel_mono_strong[OF *(2)] *(1) in_trancl_mono[of TI TI']
by (metis (no_types, lifting) equal_mod_timpls.simps(2) set_rev_mp)
qed auto
lemma equal_mod_timpls_refl_minus_eq:
"equal_mod_timpls TI s t ⟷ equal_mod_timpls (filter (λ(a,b). a ≠ b) TI) s t"
(is "?A ⟷ ?B")
proof
show ?A when ?B using that equal_mod_timpls_mono[of "filter (λ(a,b). a ≠ b) TI" TI] by auto
show ?B when ?A using that
proof (induction TI s t rule: equal_mod_timpls.induct)
case (2 TI f T g S)
define TI' where "TI' ≡ filter (λ(a,b). a ≠ b) TI"
let ?P = "λX Y. f = g ∨ (is_Abs f ∧ is_Abs g ∧ ((the_Abs f, the_Abs g) ∈ set X ∨
(the_Abs g, the_Abs f) ∈ set X ∨ (∃ti ∈ set Y.
(the_Abs f, snd ti) ∈ set X ∧ (the_Abs g, snd ti) ∈ set X)))"
have *: "?P TI TI" "list_all2 (equal_mod_timpls TI) T S"
using "2.prems" by simp_all
have "?P TI' TI"
using *(1) unfolding TI'_def is_Abs_def by auto
hence "?P TI' TI'"
by (metis (no_types, lifting) snd_conv)
moreover have "list_all2 (equal_mod_timpls TI') T S"
using *(2) "2.IH" list.rel_mono_strong unfolding TI'_def by blast
ultimately show ?case unfolding TI'_def by force
qed auto
qed
lemma timpls_transformable_to_refl:
"timpls_transformable_to TI t t" (is ?A)
"timpls_transformable_to' TI t t" (is ?B)
by (induct t) (auto simp add: list_all2_conv_all_nth)
lemma timpls_transformable_to_inv_Var:
"timpls_transformable_to TI (Var x) t ⟹ t = Var x" (is "?A ⟹ ?C")
"timpls_transformable_to TI t (Var x) ⟹ t = Var x" (is "?B ⟹ ?C")
"timpls_transformable_to' TI (Var x) t ⟹ t = Var x" (is "?A' ⟹ ?C")
"timpls_transformable_to' TI t (Var x) ⟹ t = Var x" (is "?B' ⟹ ?C")
by (cases t; auto)+
lemma timpls_transformable_to_inv:
assumes "timpls_transformable_to TI (Fun f T) (Fun g S)"
shows "length T = length S"
and "⋀i. i < length T ⟹ timpls_transformable_to TI (T ! i) (S ! i)"
and "f ≠ g ⟹ (is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set TI)"
using assms list_all2_conv_all_nth[of "timpls_transformable_to TI" T S] by auto
lemma timpls_transformable_to'_inv:
assumes "timpls_transformable_to' TI (Fun f T) (Fun g S)"
shows "length T = length S"
and "⋀i. i < length T ⟹ timpls_transformable_to' TI (T ! i) (S ! i)"
and "f ≠ g ⟹ (is_Abs f ∧ is_Abs g ∧ in_trancl TI (the_Abs f) (the_Abs g))"
using assms list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S] by auto
lemma timpls_transformable_to_inv':
assumes "timpls_transformable_to TI (Fun f T) t"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ timpls_transformable_to TI (T ! i) (args t ! i)"
and "f ≠ the_Fun t ⟹ (
is_Abs f ∧ is_Abs (the_Fun t) ∧ (the_Abs f, the_Abs (the_Fun t)) ∈ set TI)"
and "¬is_Abs f ⟹ f = the_Fun t"
using assms list_all2_conv_all_nth[of "timpls_transformable_to TI" T]
by (cases t; auto)+
lemma timpls_transformable_to'_inv':
assumes "timpls_transformable_to' TI (Fun f T) t"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ timpls_transformable_to' TI (T ! i) (args t ! i)"
and "f ≠ the_Fun t ⟹ (
is_Abs f ∧ is_Abs (the_Fun t) ∧ in_trancl TI (the_Abs f) (the_Abs (the_Fun t)))"
and "¬is_Abs f ⟹ f = the_Fun t"
using assms list_all2_conv_all_nth[of "timpls_transformable_to' TI" T]
by (cases t; auto)+
lemma timpls_transformable_to_size_eq:
fixes s t::"(('b, 'c, 'a) prot_fun, 'd) term"
shows "timpls_transformable_to TI s t ⟹ size s = size t" (is "?A ⟹ ?C")
and "timpls_transformable_to' TI s t ⟹ size s = size t" (is "?B ⟹ ?C")
proof -
have *: "size_list size T = size_list size S"
when "length T = length S" "⋀i. i < length T ⟹ size (T ! i) = size (S ! i)"
for S T::"(('b, 'c, 'a) prot_fun, 'd) term list"
using that
proof (induction T arbitrary: S)
case (Cons x T')
then obtain y S' where y: "S = y#S'" by (cases S) auto
hence "size_list size T' = size_list size S'" "size x = size y"
using Cons.prems Cons.IH[of S'] by force+
thus ?case using y by simp
qed simp
show ?C when ?A using that
proof (induction rule: timpls_transformable_to.induct)
case (2 TI f T g S)
hence "length T = length S" "⋀i. i < length T ⟹ size (T ! i) = size (S ! i)"
using timpls_transformable_to_inv(1,2)[of TI f T g S] by auto
thus ?case using *[of S T] by simp
qed simp_all
show ?C when ?B using that
proof (induction rule: timpls_transformable_to.induct)
case (2 TI f T g S)
hence "length T = length S" "⋀i. i < length T ⟹ size (T ! i) = size (S ! i)"
using timpls_transformable_to'_inv(1,2)[of TI f T g S] by auto
thus ?case using *[of S T] by simp
qed simp_all
qed
lemma timpls_transformable_to_if_term_variants:
fixes s t::"(('a, 'b, 'c) prot_fun, 'd) term" and a b::"'c set"
defines "P ≡ (λ_. [])(Abs a := [Abs b])"
assumes st: "term_variants_pred P s t"
and ab: "(a,b) ∈ set TI"
shows "timpls_transformable_to TI s t"
using st P_def
proof (induction rule: term_variants_pred.induct)
case (term_variants_P T S f) thus ?case
using ab list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
by auto
next
case (term_variants_Fun T S f) thus ?case
using ab list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
by auto
qed simp
lemma timpls_transformable_to'_if_term_variants:
fixes s t::"(('a, 'b, 'c) prot_fun, 'd) term" and a b::"'c set"
defines "P ≡ (λ_. [])(Abs a := [Abs b])"
assumes st: "term_variants_pred P s t"
and ab: "(a,b) ∈ (set TI)⇧+"
shows "timpls_transformable_to' TI s t"
using st P_def
proof (induction rule: term_variants_pred.induct)
case (term_variants_P T S f) thus ?case
using ab list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
by auto
next
case (term_variants_Fun T S f) thus ?case
using ab list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
by auto
qed simp
lemma timpls_transformable_to_trans:
assumes TI_trancl: "∀(a,b) ∈ (set TI)⇧+. a ≠ b ⟶ (a,b) ∈ set TI"
and st: "timpls_transformable_to TI s t"
and tu: "timpls_transformable_to TI t u"
shows "timpls_transformable_to TI s u"
using st tu
proof (induction s arbitrary: t u)
case (Var x) thus ?case using tu timpls_transformable_to_inv_Var(1) by fast
next
case (Fun f T)
obtain g S where t:
"t = Fun g S" "length T = length S"
"⋀i. i < length T ⟹ timpls_transformable_to TI (T ! i) (S ! i)"
"f ≠ g ⟹ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set TI"
using timpls_transformable_to_inv'[OF Fun.prems(1)] TI_trancl by moura
obtain h U where u:
"u = Fun h U" "length S = length U"
"⋀i. i < length S ⟹ timpls_transformable_to TI (S ! i) (U ! i)"
"g ≠ h ⟹ is_Abs g ∧ is_Abs h ∧ (the_Abs g, the_Abs h) ∈ set TI"
using timpls_transformable_to_inv'[OF Fun.prems(2)[unfolded t(1)]] TI_trancl by moura
have "list_all2 (timpls_transformable_to TI) T U"
using t(1,2,3) u(1,2,3) Fun.IH
list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
list_all2_conv_all_nth[of "timpls_transformable_to TI" S U]
list_all2_conv_all_nth[of "timpls_transformable_to TI" T U]
by force
moreover have "(the_Abs f, the_Abs h) ∈ set TI"
when "(the_Abs f, the_Abs g) ∈ set TI" "(the_Abs g, the_Abs h) ∈ set TI"
"f ≠ h" "is_Abs f" "is_Abs h"
using that(3,4,5) TI_trancl trancl_into_trancl[OF r_into_trancl[OF that(1)] that(2)]
unfolding is_Abs_def the_Abs_def
by force
hence "is_Abs f ∧ is_Abs h ∧ (the_Abs f, the_Abs h) ∈ set TI"
when "f ≠ h"
using that TI_trancl t(4) u(4) by fast
ultimately show ?case using t(1) u(1) by force
qed
lemma timpls_transformable_to'_trans:
assumes st: "timpls_transformable_to' TI s t"
and tu: "timpls_transformable_to' TI t u"
shows "timpls_transformable_to' TI s u"
using st tu
proof (induction s arbitrary: t u)
case (Var x) thus ?case using tu timpls_transformable_to_inv_Var(3) by fast
next
case (Fun f T)
note 0 = in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
obtain g S where t:
"t = Fun g S" "length T = length S"
"⋀i. i < length T ⟹ timpls_transformable_to' TI (T ! i) (S ! i)"
"f ≠ g ⟹ is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ (set TI)⇧+"
using timpls_transformable_to'_inv'[OF Fun.prems(1)] 0 by moura
obtain h U where u:
"u = Fun h U" "length S = length U"
"⋀i. i < length S ⟹ timpls_transformable_to' TI (S ! i) (U ! i)"
"g ≠ h ⟹ is_Abs g ∧ is_Abs h ∧ (the_Abs g, the_Abs h) ∈ (set TI)⇧+"
using timpls_transformable_to'_inv'[OF Fun.prems(2)[unfolded t(1)]] 0 by moura
have "list_all2 (timpls_transformable_to' TI) T U"
using t(1,2,3) u(1,2,3) Fun.IH
list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
list_all2_conv_all_nth[of "timpls_transformable_to' TI" S U]
list_all2_conv_all_nth[of "timpls_transformable_to' TI" T U]
by force
moreover have "(the_Abs f, the_Abs h) ∈ (set TI)⇧+"
when "(the_Abs f, the_Abs g) ∈ (set TI)⇧+" "(the_Abs g, the_Abs h) ∈ (set TI)⇧+"
using that by simp
hence "is_Abs f ∧ is_Abs h ∧ (the_Abs f, the_Abs h) ∈ (set TI)⇧+"
when "f ≠ h"
by (metis that t(4) u(4))
ultimately show ?case using t(1) u(1) 0 by force
qed
lemma timpls_transformable_to_mono:
assumes "set TI ⊆ set TI'"
and "timpls_transformable_to TI s t"
shows "timpls_transformable_to TI' s t"
using assms
proof (induction TI s t rule: timpls_transformable_to.induct)
case (2 TI f T g S)
have *: "f = g ∨ (is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set TI)"
"list_all2 (timpls_transformable_to TI) T S"
using "2.prems" by simp_all
show ?case
using "2.IH" "2.prems"(1) list.rel_mono_strong[OF *(2)] *(1) in_trancl_mono[of TI TI']
by (metis (no_types, lifting) timpls_transformable_to.simps(2) set_rev_mp)
qed auto
lemma timpls_transformable_to'_mono:
assumes "set TI ⊆ set TI'"
and "timpls_transformable_to' TI s t"
shows "timpls_transformable_to' TI' s t"
using assms
proof (induction TI s t rule: timpls_transformable_to'.induct)
case (2 TI f T g S)
have *: "f = g ∨ (is_Abs f ∧ is_Abs g ∧ in_trancl TI (the_Abs f) (the_Abs g))"
"list_all2 (timpls_transformable_to' TI) T S"
using "2.prems" by simp_all
show ?case
using "2.IH" "2.prems"(1) list.rel_mono_strong[OF *(2)] *(1) in_trancl_mono[of TI TI']
by (metis (no_types, lifting) timpls_transformable_to'.simps(2))
qed auto
lemma timpls_transformable_to_refl_minus_eq:
"timpls_transformable_to TI s t ⟷ timpls_transformable_to (filter (λ(a,b). a ≠ b) TI) s t"
(is "?A ⟷ ?B")
proof
let ?TI' = "λTI. filter (λ(a,b). a ≠ b) TI"
show ?A when ?B using that timpls_transformable_to_mono[of "?TI' TI" TI] by auto
show ?B when ?A using that
proof (induction TI s t rule: timpls_transformable_to.induct)
case (2 TI f T g S)
have *: "f = g ∨ (is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set TI)"
"list_all2 (timpls_transformable_to TI) T S"
using "2.prems" by simp_all
have "f = g ∨ (is_Abs f ∧ is_Abs g ∧ (the_Abs f, the_Abs g) ∈ set (?TI' TI))"
using *(1) unfolding is_Abs_def by auto
moreover have "list_all2 (timpls_transformable_to (?TI' TI)) T S"
using *(2) "2.IH" list.rel_mono_strong by blast
ultimately show ?case by force
qed auto
qed
lemma timpls_transformable_to_iff_in_timpl_closure:
assumes "set TI' = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
shows "timpls_transformable_to TI' s t ⟷ t ∈ timpl_closure s (set TI)" (is "?A s t ⟷ ?B s t")
proof
show "?A s t ⟹ ?B s t" using assms
proof (induction s t rule: timpls_transformable_to.induct)
case (2 TI f T g S)
note prems = "2.prems"
note IH = "2.IH"
have 1: "length T = length S" "∀i<length T. timpls_transformable_to TI' (T ! i) (S ! i)"
using prems(1) list_all2_conv_all_nth[of "timpls_transformable_to TI'" T S] by simp_all
note 2 = timpl_closure_is_timpl_closure'
note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
have 4: "timpl_closure' (set TI') = timpl_closure' (set TI)"
using timpl_closure'_timpls_trancl_eq'[of "set TI"] prems(2) by simp
have IH': "(T ! i, S ! i) ∈ timpl_closure' (set TI')" when i: "i < length S" for i
proof -
have "timpls_transformable_to TI' (T ! i) (S ! i)" using i 1 by presburger
hence "S ! i ∈ timpl_closure (T ! i) (set TI)"
using IH[of "T ! i" "S ! i"] i 1(1) prems(2) by force
thus ?thesis using 2[of "S ! i" "T ! i" "set TI"] 4 by blast
qed
have 5: "f = g ∨ (∃a b. (a, b) ∈ (set TI')⇧+ ∧ f = Abs a ∧ g = Abs b)"
using prems(1) the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g]
by fastforce
show ?case using 2 4 timpl_closure_FunI[OF IH' 1(1) 5] 1(1) by auto
qed (simp_all add: timpl_closure.FP)
show "?B s t ⟹ ?A s t"
proof (induction t rule: timpl_closure.induct)
case (TI u a b v) show ?case
proof (cases "a = b")
case True thus ?thesis using TI.hyps(3) TI.IH term_variants_pred_refl_inv by fastforce
next
case False
hence 1: "timpls_transformable_to TI' u v"
using TI.hyps(2) assms timpls_transformable_to_if_term_variants[OF TI.hyps(3), of TI']
by blast
have 2: "(c,d) ∈ set TI'" when cd: "(c,d) ∈ (set TI')⇧+" "c ≠ d" for c d
proof -
let ?cl = "λX. {(a,b) ∈ X⇧+. a ≠ b}"
have "?cl (set TI') = ?cl (?cl (set TI))" using assms by presburger
hence "set TI' = ?cl (set TI')" using assms trancl_minus_refl_idem[of "set TI"] by argo
thus ?thesis using cd by blast
qed
show ?thesis using timpls_transformable_to_trans[OF _ TI.IH 1] 2 by blast
qed
qed (use timpls_transformable_to_refl in fast)
qed
lemma timpls_transformable_to'_iff_in_timpl_closure:
"timpls_transformable_to' TI s t ⟷ t ∈ timpl_closure s (set TI)" (is "?A s t ⟷ ?B s t")
proof
show "?A s t ⟹ ?B s t"
proof (induction s t rule: timpls_transformable_to'.induct)
case (2 TI f T g S)
note prems = "2.prems"
note IH = "2.IH"
have 1: "length T = length S" "∀i<length T. timpls_transformable_to' TI (T ! i) (S ! i)"
using prems list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S] by simp_all
note 2 = timpl_closure_is_timpl_closure'
note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
have IH': "(T ! i, S ! i) ∈ timpl_closure' (set TI)" when i: "i < length S" for i
proof -
have "timpls_transformable_to' TI (T ! i) (S ! i)" using i 1 by presburger
hence "S ! i ∈ timpl_closure (T ! i) (set TI)" using IH[of "T ! i" "S ! i"] i 1(1) by force
thus ?thesis using 2[of "S ! i" "T ! i" "set TI"] by blast
qed
have 4: "f = g ∨ (∃a b. (a, b) ∈ (set TI)⇧+ ∧ f = Abs a ∧ g = Abs b)"
using prems the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g]
in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
by auto
show ?case using 2 timpl_closure_FunI[OF IH' 1(1) 4] 1(1) by auto
qed (simp_all add: timpl_closure.FP)
show "?B s t ⟹ ?A s t"
proof (induction t rule: timpl_closure.induct)
case (TI u a b v) thus ?case
using timpls_transformable_to'_trans
timpls_transformable_to'_if_term_variants
by blast
qed (use timpls_transformable_to_refl(2) in fast)
qed
lemma equal_mod_timpls_iff_ex_in_timpl_closure:
assumes "set TI' = {(a,b) ∈ TI⇧+. a ≠ b}"
shows "equal_mod_timpls TI' s t ⟷ (∃u. u ∈ timpl_closure s TI ∧ u ∈ timpl_closure t TI)"
(is "?A s t ⟷ ?B s t")
proof
show "?A s t ⟹ ?B s t" using assms
proof (induction s t rule: equal_mod_timpls.induct)
case (2 TI' f T g S)
note prems = "2.prems"
note IH = "2.IH"
have 1: "length T = length S" "∀i<length T. equal_mod_timpls (TI') (T ! i) (S ! i)"
using prems list_all2_conv_all_nth[of "equal_mod_timpls TI'" T S] by simp_all
note 2 = timpl_closure_is_timpl_closure'
note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
have 4: "timpl_closure' (set TI') = timpl_closure' TI"
using timpl_closure'_timpls_trancl_eq'[of TI] prems
by simp
have IH: "∃u. (T ! i, u) ∈ timpl_closure' TI ∧ (S ! i, u) ∈ timpl_closure' TI"
when i: "i < length S" for i
proof -
have "equal_mod_timpls TI' (T ! i) (S ! i)" using i 1 by presburger
hence "∃u. u ∈ timpl_closure (T ! i) TI ∧ u ∈ timpl_closure (S ! i) TI"
using IH[of "T ! i" "S ! i"] i 1(1) prems by force
thus ?thesis using 4 unfolding 2 by blast
qed
let ?P = "λG. f = g ∨ (∃a b. (a, b) ∈ G ∧ f = Abs a ∧ g = Abs b) ∨
(∃a b. (a, b) ∈ G ∧ f = Abs b ∧ g = Abs a) ∨
(∃a b c. (a, c) ∈ G ∧ (b, c) ∈ G ∧ f = Abs a ∧ g = Abs b)"
have "?P (set TI')"
using prems the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g]
by fastforce
hence "?P (TI⇧+)" unfolding prems by blast
hence "?P (rtrancl TI)" by (metis (no_types, lifting) trancl_into_rtrancl)
hence 5: "f = g ∨ (∃a b c. (a, c) ∈ TI⇧* ∧ (b, c) ∈ TI⇧* ∧ f = Abs a ∧ g = Abs b)" by blast
show ?case
using timpl_closure_FunI3[OF _ 1(1) 5] IH 1(1)
unfolding timpl_closure'_timpls_rtrancl_eq 2
by auto
qed (use timpl_closure.FP in auto)
show "?A s t" when B: "?B s t"
proof -
obtain u where u: "u ∈ timpl_closure s TI" "u ∈ timpl_closure t TI"
using B by moura
thus ?thesis using assms
proof (induction u arbitrary: s t rule: term.induct)
case (Var x s t) thus ?case
using timpl_closure_Var_in_iff[of x s TI]
timpl_closure_Var_in_iff[of x t TI]
equal_mod_timpls.simps(1)[of TI' x x]
by blast
next
case (Fun f U s t)
obtain g S where s:
"s = Fun g S" "length U = length S"
"⋀i. i < length U ⟹ U ! i ∈ timpl_closure (S ! i) TI"
"g ≠ f ⟹ is_Abs g ∧ is_Abs f ∧ (the_Abs g, the_Abs f) ∈ TI⇧+"
using Fun.prems(1) timpl_closure_Fun_inv'[of f U _ _ TI]
by (cases s) auto
obtain h T where t:
"t = Fun h T" "length U = length T"
"⋀i. i < length U ⟹ U ! i ∈ timpl_closure (T ! i) TI"
"h ≠ f ⟹ is_Abs h ∧ is_Abs f ∧ (the_Abs h, the_Abs f) ∈ TI⇧+"
using Fun.prems(2) timpl_closure_Fun_inv'[of f U _ _ TI]
by (cases t) auto
have g: "(the_Abs g, the_Abs f) ∈ set TI'" "is_Abs f" "is_Abs g" when neq_f: "g ≠ f"
proof -
obtain ga fa where a: "g = Abs ga" "f = Abs fa"
using s(4)[OF neq_f] unfolding is_Abs_def by presburger
hence "the_Abs g ≠ the_Abs f" using neq_f by simp
thus "(the_Abs g, the_Abs f) ∈ set TI'" "is_Abs f" "is_Abs g"
using s(4)[OF neq_f] Fun.prems by blast+
qed
have h: "(the_Abs h, the_Abs f) ∈ set TI'" "is_Abs f" "is_Abs h" when neq_f: "h ≠ f"
proof -
obtain ha fa where a: "h = Abs ha" "f = Abs fa"
using t(4)[OF neq_f] unfolding is_Abs_def by presburger
hence "the_Abs h ≠ the_Abs f" using neq_f by simp
thus "(the_Abs h, the_Abs f) ∈ set TI'" "is_Abs f" "is_Abs h"
using t(4)[OF neq_f] Fun.prems by blast+
qed
have "equal_mod_timpls TI' (S ! i) (T ! i)"
when i: "i < length U" for i
using i Fun.IH s(1,2,3) t(1,2,3) nth_mem[OF i] Fun.prems by meson
hence "list_all2 (equal_mod_timpls TI') S T"
using list_all2_conv_all_nth[of "equal_mod_timpls TI'" S T] s(2) t(2) by presburger
thus ?case using s(1) t(1) g h by fastforce
qed
qed
qed
context
begin
private inductive timpls_transformable_to_pred where
Var: "timpls_transformable_to_pred A (Var x) (Var x)"
| Fun: "⟦¬is_Abs f; length T = length S;
⋀i. i < length T ⟹ timpls_transformable_to_pred A (T ! i) (S ! i)⟧
⟹ timpls_transformable_to_pred A (Fun f T) (Fun f S)"
| Abs: "b ∈ A ⟹ timpls_transformable_to_pred A (Fun (Abs a) []) (Fun (Abs b) [])"
private lemma timpls_transformable_to_pred_inv_Var:
assumes "timpls_transformable_to_pred A (Var x) t"
shows "t = Var x"
using assms by (auto elim: timpls_transformable_to_pred.cases)
private lemma timpls_transformable_to_pred_inv:
assumes "timpls_transformable_to_pred A (Fun f T) t"
shows "is_Fun t"
and "length T = length (args t)"
and "⋀i. i < length T ⟹ timpls_transformable_to_pred A (T ! i) (args t ! i)"
and "¬is_Abs f ⟹ f = the_Fun t"
and "is_Abs f ⟹ (is_Abs (the_Fun t) ∧ the_Abs (the_Fun t) ∈ A)"
using assms by (auto elim!: timpls_transformable_to_pred.cases[of A])
private lemma timpls_transformable_to_pred_finite_aux1:
assumes f: "¬is_Abs f"
shows "{s. timpls_transformable_to_pred A (Fun f T) s} ⊆
(λS. Fun f S) ` {S. length T = length S ∧
(∀s ∈ set S. ∃t ∈ set T. timpls_transformable_to_pred A t s)}"
(is "?B ⊆ ?C")
proof
fix s assume s: "s ∈ ?B"
hence *: "timpls_transformable_to_pred A (Fun f T) s" by blast
obtain S where S:
"s = Fun f S" "length T = length S" "⋀i. i < length T ⟹ timpls_transformable_to_pred A (T ! i) (S ! i)"
using f timpls_transformable_to_pred_inv[OF *] unfolding the_Abs_def is_Abs_def by auto
have "∀s∈set S. ∃t∈set T. timpls_transformable_to_pred A t s" using S(2,3) in_set_conv_nth by metis
thus "s ∈ ?C" using S(1,2) by blast
qed
private lemma timpls_transformable_to_pred_finite_aux2:
"{s. timpls_transformable_to_pred A (Fun (Abs a) []) s} ⊆ (λb. Fun (Abs b) []) ` A" (is "?B ⊆ ?C")
proof
fix s assume s: "s ∈ ?B"
hence *: "timpls_transformable_to_pred A (Fun (Abs a) []) s" by blast
obtain b where b: "s = Fun (Abs b) []" "b ∈ A"
using timpls_transformable_to_pred_inv[OF *] unfolding the_Abs_def is_Abs_def by auto
thus "s ∈ ?C" by blast
qed
private lemma timpls_transformable_to_pred_finite:
fixes t::"(('fun,'atom,'sets) prot_fun, 'a) term"
assumes A: "finite A"
and t: "wf⇩t⇩r⇩m t"
shows "finite {s. timpls_transformable_to_pred A t s}"
using t
proof (induction t)
case (Var x)
have "{s::(('fun,'atom,'sets) prot_fun, 'a) term. timpls_transformable_to_pred A (Var x) s} = {Var x}"
by (auto intro: timpls_transformable_to_pred.Var elim: timpls_transformable_to_pred_inv_Var)
thus ?case by simp
next
case (Fun f T)
have IH: "finite {s. timpls_transformable_to_pred A t s}" when t: "t ∈ set T" for t
using Fun.IH[OF t] wf_trm_param[OF Fun.prems t] by blast
show ?case
proof (cases "is_Abs f")
case True
then obtain a where a: "f = Abs a" unfolding is_Abs_def by presburger
hence "T = []" using wf_trm_arity[OF Fun.prems] by simp_all
hence "{a. timpls_transformable_to_pred A (Fun f T) a} ⊆ (λb. Fun (Abs b) []) ` A"
using timpls_transformable_to_pred_finite_aux2[of A a] a by auto
thus ?thesis using A finite_subset by fast
next
case False thus ?thesis
using IH finite_lists_length_eq' timpls_transformable_to_pred_finite_aux1[of f A T] finite_subset
by blast
qed
qed
private lemma timpls_transformable_to_pred_if_timpls_transformable_to:
assumes s: "timpls_transformable_to TI t s"
and t: "wf⇩t⇩r⇩m t" "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A"
shows "timpls_transformable_to_pred (A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+) t s"
using s t
proof (induction rule: timpls_transformable_to.induct)
case (2 TI f T g S)
let ?A = "A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+"
note prems = "2.prems"
note IH = "2.IH"
note 0 = timpls_transformable_to_inv[OF prems(1)]
have 1: "T = []" "S = []" when f: "f = Abs a" for a
using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
have "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A" when t: "t ∈ set T" for t
using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
when i: "i < length T" for i
using i IH 0(1,2) wf_trm_param[OF prems(2)]
by (metis (no_types) in_set_conv_nth)
have 3: "the_Abs f ∈ ?A" when f: "is_Abs f" using prems(3) f by force
show ?case
proof (cases "f = g")
case True
note fg = True
show ?thesis
proof (cases "is_Abs f")
case True
then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
next
case False
then obtain a b where ab: "f = Abs a" "g = Abs b" "(a, b) ∈ (set TI)⇧+"
using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
unfolding is_Abs_def the_Abs_def by fastforce
hence "a ∈ ?A" "b ∈ ?A" by force+
thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
qed
qed (simp_all add: timpls_transformable_to_pred.Var)
private lemma timpls_transformable_to_pred_if_timpls_transformable_to':
assumes s: "timpls_transformable_to' TI t s"
and t: "wf⇩t⇩r⇩m t" "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A"
shows "timpls_transformable_to_pred (A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+) t s"
using s t
proof (induction rule: timpls_transformable_to.induct)
case (2 TI f T g S)
let ?A = "A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+"
note prems = "2.prems"
note IH = "2.IH"
note 0 = timpls_transformable_to'_inv[OF prems(1)]
have 1: "T = []" "S = []" when f: "f = Abs a" for a
using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
have "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A" when t: "t ∈ set T" for t
using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
when i: "i < length T" for i
using i IH 0(1,2) wf_trm_param[OF prems(2)]
by (metis (no_types) in_set_conv_nth)
have 3: "the_Abs f ∈ ?A" when f: "is_Abs f" using prems(3) f by force
show ?case
proof (cases "f = g")
case True
note fg = True
show ?thesis
proof (cases "is_Abs f")
case True
then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
next
case False
then obtain a b where ab: "f = Abs a" "g = Abs b" "(a, b) ∈ (set TI)⇧+"
using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
unfolding is_Abs_def the_Abs_def by fastforce
hence "a ∈ ?A" "b ∈ ?A" by force+
thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
qed
qed (simp_all add: timpls_transformable_to_pred.Var)
private lemma timpls_transformable_to_pred_if_equal_mod_timpls:
assumes s: "equal_mod_timpls TI t s"
and t: "wf⇩t⇩r⇩m t" "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A"
shows "timpls_transformable_to_pred (A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+) t s"
using s t
proof (induction rule: equal_mod_timpls.induct)
case (2 TI f T g S)
let ?A = "A ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+"
note prems = "2.prems"
note IH = "2.IH"
note 0 = equal_mod_timpls_inv[OF prems(1)]
have 1: "T = []" "S = []" when f: "f = Abs a" for a
using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
have "∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ A" when t: "t ∈ set T" for t
using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
when i: "i < length T" for i
using i IH 0(1,2) wf_trm_param[OF prems(2)]
by (metis (no_types) in_set_conv_nth)
have 3: "the_Abs f ∈ ?A" when f: "is_Abs f" using prems(3) f by force
show ?case
proof (cases "f = g")
case True
note fg = True
show ?thesis
proof (cases "is_Abs f")
case True
then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
next
case False
then obtain a b where ab: "f = Abs a" "g = Abs b"
"(a, b) ∈ (set TI)⇧+ ∨ (b, a) ∈ (set TI)⇧+ ∨
(∃ti ∈ set TI. (a, snd ti) ∈ (set TI)⇧+ ∧ (b, snd ti) ∈ (set TI)⇧+)"
using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
unfolding is_Abs_def the_Abs_def by fastforce
hence "a ∈ ?A" "b ∈ ?A" by force+
thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
qed
qed (simp_all add: timpls_transformable_to_pred.Var)
lemma timpls_transformable_to_finite:
assumes t: "wf⇩t⇩r⇩m t"
shows "finite {s. timpls_transformable_to TI t s}" (is ?P)
and "finite {s. timpls_transformable_to' TI t s}" (is ?Q)
proof -
let ?A = "the_Abs ` {f ∈ funs_term t. is_Abs f} ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+"
have 0: "finite ?A" by auto
have 1: "{s. timpls_transformable_to TI t s} ⊆ {s. timpls_transformable_to_pred ?A t s}"
using timpls_transformable_to_pred_if_timpls_transformable_to[OF _ t] by auto
have 2: "{s. timpls_transformable_to' TI t s} ⊆ {s. timpls_transformable_to_pred ?A t s}"
using timpls_transformable_to_pred_if_timpls_transformable_to'[OF _ t] by auto
show ?P using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 1] by blast
show ?Q using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 2] by blast
qed
lemma equal_mod_timpls_finite:
assumes t: "wf⇩t⇩r⇩m t"
shows "finite {s. equal_mod_timpls TI t s}"
proof -
let ?A = "the_Abs ` {f ∈ funs_term t. is_Abs f} ∪ fst ` (set TI)⇧+ ∪ snd ` (set TI)⇧+"
have 0: "finite ?A" by auto
have 1: "{s. equal_mod_timpls TI t s} ⊆ {s. timpls_transformable_to_pred ?A t s}"
using timpls_transformable_to_pred_if_equal_mod_timpls[OF _ t] by auto
show ?thesis using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 1] by blast
qed
end
lemma intruder_synth_mod_timpls_is_synth_timpl_closure_set:
fixes t::"(('fun, 'atom, 'sets) prot_fun, 'a) term" and TI TI'
assumes "set TI' = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
shows "intruder_synth_mod_timpls M TI' t ⟷ timpl_closure_set (set M) (set TI) ⊢⇩c t"
(is "?C t ⟷ ?D t")
proof -
have *: "(∃m ∈ M. timpls_transformable_to TI' m t) ⟷ t ∈ timpl_closure_set M (set TI)"
when "set TI' = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
for M TI TI' and t::"(('fun, 'atom, 'sets) prot_fun, 'a) term"
using timpls_transformable_to_iff_in_timpl_closure[OF that]
timpl_closure_set_is_timpl_closure_union[of M "set TI"]
timpl_closure_set_timpls_trancl_eq[of M "set TI"]
timpl_closure_set_timpls_trancl_eq'[of M "set TI"]
by auto
show "?C t ⟷ ?D t"
proof
show "?C t ⟹ ?D t" using assms
proof (induction t arbitrary: M TI TI' rule: intruder_synth_mod_timpls.induct)
case (1 M TI' x)
hence "Var x ∈ timpl_closure_set (set M) (set TI)"
using timpl_closure.FP member_def unfolding timpl_closure_set_def by force
thus ?case by simp
next
case (2 M TI f T)
show ?case
proof (cases "∃m ∈ set M. timpls_transformable_to TI' m (Fun f T)")
case True thus ?thesis
using "2.prems" *[of TI' TI "set M" "Fun f T"]
intruder_synth.AxiomC[of "Fun f T" "timpl_closure_set (set M) (set TI)"]
by blast
next
case False
hence "¬(list_ex (λt. timpls_transformable_to TI' t (Fun f T)) M)"
unfolding list_ex_iff by blast
hence "public f" "length T = arity f" "list_all (intruder_synth_mod_timpls M TI') T"
using "2.prems"(1) by force+
thus ?thesis using "2.IH"[OF _ _ "2.prems"(2)] unfolding list_all_iff by force
qed
qed
show "?D t ⟹ ?C t"
proof (induction t rule: intruder_synth_induct)
case (AxiomC t) thus ?case
using timpl_closure_set_Var_in_iff[of _ "set M" "set TI"] *[OF assms, of "set M" t]
by (cases t rule: term.exhaust) (force simp add: member_def list_ex_iff)+
next
case (ComposeC T f) thus ?case
using list_all_iff[of "intruder_synth_mod_timpls M TI'" T]
intruder_synth_mod_timpls.simps(2)[of M TI' f T]
by blast
qed
qed
qed
lemma intruder_synth_mod_timpls'_is_synth_timpl_closure_set:
fixes t::"(('fun, 'atom, 'sets) prot_fun, 'a) term" and TI
shows "intruder_synth_mod_timpls' M TI t ⟷ timpl_closure_set (set M) (set TI) ⊢⇩c t"
(is "?A t ⟷ ?B t")
proof -
have *: "(∃m ∈ M. timpls_transformable_to' TI m t) ⟷ t ∈ timpl_closure_set M (set TI)"
for M TI and t::"(('fun, 'atom, 'sets) prot_fun, 'a) term"
using timpls_transformable_to'_iff_in_timpl_closure[of TI _ t]
timpl_closure_set_is_timpl_closure_union[of M "set TI"]
by blast+
show "?A t ⟷ ?B t"
proof
show "?A t ⟹ ?B t"
proof (induction t arbitrary: M TI rule: intruder_synth_mod_timpls'.induct)
case (1 M TI x)
hence "Var x ∈ timpl_closure_set (set M) (set TI)"
using timpl_closure.FP List.member_def[of M] unfolding timpl_closure_set_def by auto
thus ?case by simp
next
case (2 M TI f T)
show ?case
proof (cases "∃m ∈ set M. timpls_transformable_to' TI m (Fun f T)")
case True thus ?thesis
using "2.prems" *[of "set M" TI "Fun f T"]
intruder_synth.AxiomC[of "Fun f T" "timpl_closure_set (set M) (set TI)"]
by blast
next
case False
hence "public f" "length T = arity f" "list_all (intruder_synth_mod_timpls' M TI) T"
using "2.prems" list_ex_iff[of _ M] by force+
thus ?thesis
using "2.IH"[of _ M TI] list_all_iff[of "intruder_synth_mod_timpls' M TI" T]
by force
qed
qed
show "?B t ⟹ ?A t"
proof (induction t rule: intruder_synth_induct)
case (AxiomC t) thus ?case
using AxiomC timpl_closure_set_Var_in_iff[of _ "set M" "set TI"] *[of "set M" TI t]
list_ex_iff[of _ M] List.member_def[of M]
by (cases t rule: term.exhaust) force+
next
case (ComposeC T f) thus ?case
using list_all_iff[of "intruder_synth_mod_timpls' M TI" T]
intruder_synth_mod_timpls'.simps(2)[of M TI f T]
by blast
qed
qed
qed
lemma intruder_synth_mod_eq_timpls_is_synth_timpl_closure_set:
fixes t::"(('fun, 'atom, 'sets) prot_fun, 'a) term" and TI
defines "cl ≡ λTI. {(a,b) ∈ TI⇧+. a ≠ b}"
shows "set TI' = {(a,b) ∈ (set TI)⇧+. a ≠ b} ⟹
intruder_synth_mod_eq_timpls M TI' t ⟷
(∃s ∈ timpl_closure t (set TI). timpl_closure_set M (set TI) ⊢⇩c s)"
(is "?Q TI TI' ⟹ ?C t ⟷ ?D t")
proof -
have **: "(∃m ∈ M. equal_mod_timpls TI' m t) ⟷
(∃s ∈ timpl_closure t (set TI). s ∈ timpl_closure_set M (set TI))"
when Q: "?Q TI TI'"
for M TI TI' and t::"(('fun, 'atom, 'sets) prot_fun, 'a) term"
using equal_mod_timpls_iff_ex_in_timpl_closure[OF Q]
timpl_closure_set_is_timpl_closure_union[of M "set TI"]
timpl_closure_set_timpls_trancl_eq'[of M "set TI"]
by fastforce
show "?C t ⟷ ?D t" when Q: "?Q TI TI'"
proof
show "?C t ⟹ ?D t" using Q
proof (induction t arbitrary: M TI rule: intruder_synth_mod_eq_timpls.induct)
case (1 M TI' x M TI)
hence "Var x ∈ timpl_closure_set M (set TI)" "Var x ∈ timpl_closure (Var x) (set TI)"
using timpl_closure.FP unfolding timpl_closure_set_def by auto
thus ?case by force
next
case (2 M TI' f T M TI)
show ?case
proof (cases "∃m ∈ M. equal_mod_timpls TI' m (Fun f T)")
case True thus ?thesis
using **[OF "2.prems"(2), of M "Fun f T"]
intruder_synth.AxiomC[of _ "timpl_closure_set M (set TI)"]
by blast
next
case False
hence f: "public f" "length T = arity f" "list_all (intruder_synth_mod_eq_timpls M TI') T"
using "2.prems" by force+
let ?sy = "intruder_synth (timpl_closure_set M (set TI))"
have IH: "∃u ∈ timpl_closure (T ! i) (set TI). ?sy u"
when i: "i < length T" for i
using "2.IH"[of _ M TI] f(3) nth_mem[OF i] "2.prems"(2)
unfolding list_all_iff by blast
define S where "S ≡ map (λu. SOME v. v ∈ timpl_closure u (set TI) ∧ ?sy v) T"
have S1: "length T = length S"
unfolding S_def by simp
have S2: "S ! i ∈ timpl_closure (T ! i) (set TI)"
"timpl_closure_set M (set TI) ⊢⇩c S ! i"
when i: "i < length S" for i
using i IH someI_ex[of "λv. v ∈ timpl_closure (T ! i) (set TI) ∧ ?sy v"]
unfolding S_def by auto
have "Fun f S ∈ timpl_closure (Fun f T) (set TI)"
using timpl_closure_FunI[of T S "set TI" f f] S1 S2(1)
unfolding timpl_closure_is_timpl_closure' by presburger
thus ?thesis
by (metis intruder_synth.ComposeC[of S f] f(1,2) S1 S2(2) in_set_conv_nth[of _ S])
qed
qed
show "?C t" when D: "?D t"
proof -
obtain s where "timpl_closure_set M (set TI) ⊢⇩c s" "s ∈ timpl_closure t (set TI)"
using D by moura
thus ?thesis
proof (induction s arbitrary: t rule: intruder_synth_induct)
case (AxiomC s t)
note 1 = timpl_closure_set_Var_in_iff[of _ M "set TI"] timpl_closure_Var_inv[of s _ "set TI"]
note 2 = **[OF Q, of M]
show ?case
proof (cases t)
case Var thus ?thesis using 1 AxiomC by auto
next
case Fun thus ?thesis using 2 AxiomC by auto
qed
next
case (ComposeC T f t)
obtain g S where gS:
"t = Fun g S" "length S = length T"
"∀i < length T. T ! i ∈ timpl_closure (S ! i) (set TI)"
"g ≠ f ⟹ is_Abs g ∧ is_Abs f ∧ (the_Abs g, the_Abs f) ∈ (set TI)⇧+"
using ComposeC.prems(1) timpl_closure'_inv'[of t "Fun f T" "set TI"]
timpl_closure_is_timpl_closure'[of _ _ "set TI"]
by fastforce
have IH: "intruder_synth_mod_eq_timpls M TI' u" when u: "u ∈ set S" for u
by (metis u gS(2,3) ComposeC.IH in_set_conv_nth)
note 0 = list_all_iff[of "intruder_synth_mod_eq_timpls M TI'" S]
intruder_synth_mod_eq_timpls.simps(2)[of M TI' g S]
have "f = g" using ComposeC.hyps gS(4) unfolding is_Abs_def by fastforce
thus ?case by (metis ComposeC.hyps(1,2) gS(1,2) IH 0)
qed
qed
qed
qed
lemma timpl_closure_finite:
assumes t: "wf⇩t⇩r⇩m t"
shows "finite (timpl_closure t (set TI))"
using timpls_transformable_to'_iff_in_timpl_closure[of TI t]
timpls_transformable_to_finite[OF t, of TI]
by auto
lemma timpl_closure_set_finite:
fixes TI::"('sets set × 'sets set) list"
assumes M_finite: "finite M"
and M_wf: "wf⇩t⇩r⇩m⇩s M"
shows "finite (timpl_closure_set M (set TI))"
using timpl_closure_set_is_timpl_closure_union[of M "set TI"]
timpl_closure_finite[of _ TI] M_finite M_wf finite
by auto
lemma comp_timpl_closure_is_timpl_closure_set:
fixes M and TI::"('sets set × 'sets set) list"
assumes M_finite: "finite M"
and M_wf: "wf⇩t⇩r⇩m⇩s M"
shows "comp_timpl_closure M (set TI) = timpl_closure_set M (set TI)"
using lfp_while''[OF timpls_Un_mono[of M "set TI"]]
timpl_closure_set_finite[OF M_finite M_wf]
timpl_closure_set_lfp[of M "set TI"]
unfolding comp_timpl_closure_def Let_def by presburger
context
begin
private lemma analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux1:
fixes M::"('fun,'atom,'sets) prot_terms"
assumes f: "arity⇩f f = length T" "arity⇩f f > 0" "Ana⇩f f = (K, R)"
and i: "i < length R"
and M: "timpl_closure_set M TI ⊢⇩c T ! (R ! i)"
and m: "Fun (Fu f) T ∈ M"
and t: "Fun (Fu f) S ∈ timpl_closure (Fun (Fu f) T) TI"
shows "timpl_closure_set M TI ⊢⇩c S ! (R ! i)"
proof -
have "R ! i < length T" using i Ana⇩f_assm2_alt[OF f(3)] f(1) by simp
thus ?thesis
using timpl_closure_Fun_inv'(1,2)[OF t] intruder_synth_timpl_closure'[OF M]
by presburger
qed
private lemma analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2:
fixes M::"('fun,'atom,'sets) prot_terms"
assumes M: "∀s ∈ set (snd (Ana m)). timpl_closure_set M TI ⊢⇩c s"
and m: "m ∈ M"
and t: "t ∈ timpl_closure m TI"
and s: "s ∈ set (snd (Ana t))"
shows "timpl_closure_set M TI ⊢⇩c s"
proof -
obtain f S K N where fS: "t = Fun (Fu f) S" "arity⇩f f = length S" "0 < arity⇩f f"
and Ana_f: "Ana⇩f f = (K, N)"
and Ana_t: "Ana t = (K ⋅⇩l⇩i⇩s⇩t (!) S, map ((!) S) N)"
using Ana_nonempty_inv[of t] s by fastforce
then obtain T where T: "m = Fun (Fu f) T" "length T = length S"
using t timpl_closure_Fu_inv'[of f S m TI]
by moura
hence Ana_m: "Ana m = (K ⋅⇩l⇩i⇩s⇩t (!) T, map ((!) T) N)"
using fS(2,3) Ana_f by auto
obtain i where i: "i < length N" "s = S ! (N ! i)"
using s[unfolded fS(1)] Ana_t[unfolded fS(1)] T(2)
in_set_conv_nth[of s "map (λi. S ! i) N"]
by auto
hence "timpl_closure_set M TI ⊢⇩c T ! (N ! i)"
using M[unfolded T(1)] Ana_m[unfolded T(1)] T(2)
by simp
thus ?thesis
using analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux1[
OF fS(2)[unfolded T(2)[symmetric]] fS(3) Ana_f
i(1) _ m[unfolded T(1)] t[unfolded fS(1) T(1)]]
i(2)
by argo
qed
lemma analyzed_closed_mod_timpls_is_analyzed_timpl_closure_set:
fixes M::"('fun,'atom,'sets) prot_term list"
assumes TI': "set TI' = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
shows "analyzed_closed_mod_timpls M TI' ⟷ analyzed (timpl_closure_set (set M) (set TI))"
(is "?A ⟷ ?B")
proof
let ?C = "∀t ∈ timpl_closure_set (set M) (set TI).
analyzed_in t (timpl_closure_set (set M) (set TI))"
let ?P = "λT. ∀t ∈ set T. timpl_closure_set (set M) (set TI) ⊢⇩c t"
let ?Q = "λt. ∀s ∈ comp_timpl_closure {t} (set TI'). case Ana s of (K, R) ⇒ ?P K ⟶ ?P R"
note defs = analyzed_closed_mod_timpls_def analyzed_in_code
note 0 = intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI', of M]
note 1 = timpl_closure_set_is_timpl_closure_union[of _ "set TI"]
have 2: "comp_timpl_closure {t} (set TI') = timpl_closure_set {t} (set TI)"
when t: "t ∈ set M" "wf⇩t⇩r⇩m t" for t
using t timpl_closure_set_timpls_trancl_eq'[of "{t}" "set TI"]
comp_timpl_closure_is_timpl_closure_set[of "{t}" TI']
unfolding TI'[symmetric]
by blast
hence 3: "comp_timpl_closure {t} (set TI') ⊆ timpl_closure_set (set M) (set TI)"
when t: "t ∈ set M" "wf⇩t⇩r⇩m t" for t
using t timpl_closure_set_mono[of "{t}" "set M"]
by fast
have ?A when C: ?C
unfolding analyzed_closed_mod_timpls_def
intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
list_all_iff Let_def
proof (intro ballI)
fix t assume t: "t ∈ set M"
show "if ?P (fst (Ana t)) then ?P (snd (Ana t)) else ?Q t" (is ?R)
proof (cases "?P (fst (Ana t))")
case True
hence "?P (snd (Ana t))"
using C timpl_closure_setI[OF t, of "set TI"] prod.exhaust_sel
unfolding analyzed_in_def by blast
thus ?thesis using True by simp
next
case False
have "?Q t" using 3[OF t] C M_wf t unfolding analyzed_in_def by auto
thus ?thesis using False by argo
qed
qed
thus ?A when B: ?B using B analyzed_is_all_analyzed_in by metis
have ?C when A: ?A unfolding analyzed_in_def Let_def
proof (intro ballI allI impI; elim conjE)
fix t K T s
assume t: "t ∈ timpl_closure_set (set M) (set TI)"
and s: "s ∈ set T"
and Ana_t: "Ana t = (K, T)"
and K: "∀k ∈ set K. timpl_closure_set (set M) (set TI) ⊢⇩c k"
obtain m where m: "m ∈ set M" "t ∈ timpl_closure m (set TI)"
using timpl_closure_set_is_timpl_closure_union t by moura
show "timpl_closure_set (set M) (set TI) ⊢⇩c s"
proof (cases "∀k ∈ set (fst (Ana m)). timpl_closure_set (set M) (set TI) ⊢⇩c k")
case True
hence *: "∀r ∈ set (snd (Ana m)). timpl_closure_set (set M) (set TI) ⊢⇩c r"
using m(1) A
unfolding analyzed_closed_mod_timpls_def
intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
list_all_iff
by simp
show ?thesis
using K s Ana_t A
analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2[OF * m]
by simp
next
case False
hence "?Q m"
using m(1) A
unfolding analyzed_closed_mod_timpls_def
intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
list_all_iff Let_def
by auto
moreover have "comp_timpl_closure {m} (set TI') = timpl_closure m (set TI)"
using 2[OF m(1)] timpl_closureton_is_timpl_closure M_wf m(1)
by blast
ultimately show ?thesis
using m(2) K s Ana_t
unfolding Let_def by auto
qed
qed
thus ?B when A: ?A using A analyzed_is_all_analyzed_in by metis
qed
lemma analyzed_closed_mod_timpls'_is_analyzed_timpl_closure_set:
fixes M::"('fun,'atom,'sets) prot_term list"
assumes M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
shows "analyzed_closed_mod_timpls' M TI ⟷ analyzed (timpl_closure_set (set M) (set TI))"
(is "?A ⟷ ?B")
proof
let ?C = "∀t ∈ timpl_closure_set (set M) (set TI). analyzed_in t (timpl_closure_set (set M) (set TI))"
let ?P = "λT. ∀t ∈ set T. timpl_closure_set (set M) (set TI) ⊢⇩c t"
let ?Q = "λt. ∀s ∈ comp_timpl_closure {t} (set TI). case Ana s of (K, R) ⇒ ?P K ⟶ ?P R"
note defs = analyzed_closed_mod_timpls'_def analyzed_in_code
note 0 = intruder_synth_mod_timpls'_is_synth_timpl_closure_set[of M TI]
note 1 = timpl_closure_set_is_timpl_closure_union[of _ "set TI"]
have 2: "comp_timpl_closure {t} (set TI) = timpl_closure_set {t} (set TI)"
when t: "t ∈ set M" "wf⇩t⇩r⇩m t" for t
using t timpl_closure_set_timpls_trancl_eq[of "{t}" "set TI"]
comp_timpl_closure_is_timpl_closure_set[of "{t}"]
by blast
hence 3: "comp_timpl_closure {t} (set TI) ⊆ timpl_closure_set (set M) (set TI)"
when t: "t ∈ set M" "wf⇩t⇩r⇩m t" for t
using t timpl_closure_set_mono[of "{t}" "set M"]
by fast
have ?A when C: ?C
unfolding analyzed_closed_mod_timpls'_def
intruder_synth_mod_timpls'_is_synth_timpl_closure_set
list_all_iff Let_def
proof (intro ballI)
fix t assume t: "t ∈ set M"
show "if ?P (fst (Ana t)) then ?P (snd (Ana t)) else ?Q t" (is ?R)
proof (cases "?P (fst (Ana t))")
case True
hence "?P (snd (Ana t))"
using C timpl_closure_setI[OF t, of "set TI"] prod.exhaust_sel
unfolding analyzed_in_def by blast
thus ?thesis using True by simp
next
case False
have "?Q t" using 3[OF t] C M_wf t unfolding analyzed_in_def by auto
thus ?thesis using False by argo
qed
qed
thus ?A when B: ?B using B analyzed_is_all_analyzed_in by metis
have ?C when A: ?A unfolding analyzed_in_def Let_def
proof (intro ballI allI impI; elim conjE)
fix t K T s
assume t: "t ∈ timpl_closure_set (set M) (set TI)"
and s: "s ∈ set T"
and Ana_t: "Ana t = (K, T)"
and K: "∀k ∈ set K. timpl_closure_set (set M) (set TI) ⊢⇩c k"
obtain m where m: "m ∈ set M" "t ∈ timpl_closure m (set TI)"
using timpl_closure_set_is_timpl_closure_union t by moura
show "timpl_closure_set (set M) (set TI) ⊢⇩c s"
proof (cases "∀k ∈ set (fst (Ana m)). timpl_closure_set (set M) (set TI) ⊢⇩c k")
case True
hence *: "∀r ∈ set (snd (Ana m)). timpl_closure_set (set M) (set TI) ⊢⇩c r"
using m(1) A
unfolding analyzed_closed_mod_timpls'_def
intruder_synth_mod_timpls'_is_synth_timpl_closure_set
list_all_iff
by simp
show ?thesis
using K s Ana_t A
analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2[OF * m]
by simp
next
case False
hence "?Q m"
using m(1) A
unfolding analyzed_closed_mod_timpls'_def
intruder_synth_mod_timpls'_is_synth_timpl_closure_set
list_all_iff Let_def
by auto
moreover have "comp_timpl_closure {m} (set TI) = timpl_closure m (set TI)"
using 2[OF m(1)] timpl_closureton_is_timpl_closure M_wf m(1)
by blast
ultimately show ?thesis
using m(2) K s Ana_t
unfolding Let_def by auto
qed
qed
thus ?B when A: ?A using A analyzed_is_all_analyzed_in by metis
qed
end
end
end
Theory Stateful_Protocol_Verification
section‹Stateful Protocol Verification›
theory Stateful_Protocol_Verification
imports Stateful_Protocol_Model Term_Implication
begin
subsection ‹Fixed-Point Intruder Deduction Lemma›
context stateful_protocol_model
begin
abbreviation pubval_terms::"('fun,'atom,'sets) prot_terms" where
"pubval_terms ≡ {t. ∃f ∈ funs_term t. is_Val f ∧ public f}"
abbreviation abs_terms::"('fun,'atom,'sets) prot_terms" where
"abs_terms ≡ {t. ∃f ∈ funs_term t. is_Abs f}"
definition intruder_deduct_GSMP::
"[('fun,'atom,'sets) prot_terms,
('fun,'atom,'sets) prot_terms,
('fun,'atom,'sets) prot_term]
⇒ bool" ("⟨_;_⟩ ⊢⇩G⇩S⇩M⇩P _" 50)
where
"⟨M; T⟩ ⊢⇩G⇩S⇩M⇩P t ≡ intruder_deduct_restricted M (λt. t ∈ GSMP T - (pubval_terms ∪ abs_terms)) t"
lemma intruder_deduct_GSMP_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]:
assumes "⟨M; T⟩ ⊢⇩G⇩S⇩M⇩P t" "⋀t. t ∈ M ⟹ P M t"
"⋀S f. ⟦length S = arity f; public f;
⋀s. s ∈ set S ⟹ ⟨M; T⟩ ⊢⇩G⇩S⇩M⇩P s;
⋀s. s ∈ set S ⟹ P M s;
Fun f S ∈ GSMP T - (pubval_terms ∪ abs_terms)
⟧ ⟹ P M (Fun f S)"
"⋀t K T' t⇩i. ⟦⟨M; T⟩ ⊢⇩G⇩S⇩M⇩P t; P M t; Ana t = (K, T'); ⋀k. k ∈ set K ⟹ ⟨M; T⟩ ⊢⇩G⇩S⇩M⇩P k;
⋀k. k ∈ set K ⟹ P M k; t⇩i ∈ set T'⟧ ⟹ P M t⇩i"
shows "P M t"
proof -
let ?Q = "λt. t ∈ GSMP T - (pubval_terms ∪ abs_terms)"
show ?thesis
using intruder_deduct_restricted_induct[of M ?Q t "λM Q t. P M t"] assms
unfolding intruder_deduct_GSMP_def
by blast
qed
lemma pubval_terms_subst:
assumes "t ⋅ θ ∈ pubval_terms" "θ ` fv t ∩ pubval_terms = {}"
shows "t ∈ pubval_terms"
using assms(1,2)
proof (induction t)
case (Fun f T)
let ?P = "λf. is_Val f ∧ public f"
from Fun show ?case
proof (cases "?P f")
case False
then obtain t where t: "t ∈ set T" "t ⋅ θ ∈ pubval_terms"
using Fun.prems by auto
hence "θ ` fv t ∩ pubval_terms = {}" using Fun.prems(2) by auto
thus ?thesis using Fun.IH[OF t] t(1) by auto
qed force
qed simp
lemma abs_terms_subst:
assumes "t ⋅ θ ∈ abs_terms" "θ ` fv t ∩ abs_terms = {}"
shows "t ∈ abs_terms"
using assms(1,2)
proof (induction t)
case (Fun f T)
let ?P = "λf. is_Abs f"
from Fun show ?case
proof (cases "?P f")
case False
then obtain t where t: "t ∈ set T" "t ⋅ θ ∈ abs_terms"
using Fun.prems by auto
hence "θ ` fv t ∩ abs_terms = {}" using Fun.prems(2) by auto
thus ?thesis using Fun.IH[OF t] t(1) by auto
qed force
qed simp
lemma pubval_terms_subst':
assumes "t ⋅ θ ∈ pubval_terms" "∀n. Val (n,True) ∉ ⋃(funs_term ` (θ ` fv t))"
shows "t ∈ pubval_terms"
proof -
have "¬public f"
when fs: "f ∈ funs_term s" "s ∈ subterms⇩s⇩e⇩t (θ ` fv t)" "is_Val f"
for f s
proof -
obtain T where T: "Fun f T ∈ subterms s" using funs_term_Fun_subterm[OF fs(1)] by moura
hence "Fun f T ∈ subterms⇩s⇩e⇩t (θ ` fv t)" using fs(2) in_subterms_subset_Union by blast
thus ?thesis using assms(2) funs_term_Fun_subterm'[of f T] fs(3) by (cases f) force+
qed
thus ?thesis using pubval_terms_subst[OF assms(1)] by force
qed
lemma abs_terms_subst':
assumes "t ⋅ θ ∈ abs_terms" "∀n. Abs n ∉ ⋃(funs_term ` (θ ` fv t))"
shows "t ∈ abs_terms"
proof -
have "¬is_Abs f" when fs: "f ∈ funs_term s" "s ∈ subterms⇩s⇩e⇩t (θ ` fv t)" for f s
proof -
obtain T where T: "Fun f T ∈ subterms s" using funs_term_Fun_subterm[OF fs(1)] by moura
hence "Fun f T ∈ subterms⇩s⇩e⇩t (θ ` fv t)" using fs(2) in_subterms_subset_Union by blast
thus ?thesis using assms(2) funs_term_Fun_subterm'[of f T] by (cases f) auto
qed
thus ?thesis using abs_terms_subst[OF assms(1)] by force
qed
lemma pubval_terms_subst_range_disj:
"subst_range θ ∩ pubval_terms = {} ⟹ θ ` fv t ∩ pubval_terms = {}"
proof (induction t)
case (Var x) thus ?case by (cases "x ∈ subst_domain θ") auto
qed auto
lemma abs_terms_subst_range_disj:
"subst_range θ ∩ abs_terms = {} ⟹ θ ` fv t ∩ abs_terms = {}"
proof (induction t)
case (Var x) thus ?case by (cases "x ∈ subst_domain θ") auto
qed auto
lemma pubval_terms_subst_range_comp:
assumes "subst_range θ ∩ pubval_terms = {}" "subst_range δ ∩ pubval_terms = {}"
shows "subst_range (θ ∘⇩s δ) ∩ pubval_terms = {}"
proof -
{ fix t f assume t:
"t ∈ subst_range (θ ∘⇩s δ)" "f ∈ funs_term t" "is_Val f" "public f"
then obtain x where x: "(θ ∘⇩s δ) x = t" by auto
have "θ x ∉ pubval_terms" using assms(1) by (cases "θ x ∈ subst_range θ") force+
hence "(θ ∘⇩s δ) x ∉ pubval_terms"
using assms(2) pubval_terms_subst[of "θ x" δ] pubval_terms_subst_range_disj
by (metis (mono_tags, lifting) subst_compose_def)
hence False using t(2,3,4) x by blast
} thus ?thesis by fast
qed
lemma pubval_terms_subst_range_comp':
assumes "(θ ` X) ∩ pubval_terms = {}" "(δ ` fv⇩s⇩e⇩t (θ ` X)) ∩ pubval_terms = {}"
shows "((θ ∘⇩s δ) ` X) ∩ pubval_terms = {}"
proof -
{ fix t f assume t:
"t ∈ (θ ∘⇩s δ) ` X" "f ∈ funs_term t" "is_Val f" "public f"
then obtain x where x: "(θ ∘⇩s δ) x = t" "x ∈ X" by auto
have "θ x ∉ pubval_terms" using assms(1) x(2) by force
moreover have "fv (θ x) ⊆ fv⇩s⇩e⇩t (θ ` X)" using x(2) by (auto simp add: fv_subset)
hence "δ ` fv (θ x) ∩ pubval_terms = {}" using assms(2) by auto
ultimately have "(θ ∘⇩s δ) x ∉ pubval_terms"
using pubval_terms_subst[of "θ x" δ]
by (metis (mono_tags, lifting) subst_compose_def)
hence False using t(2,3,4) x by blast
} thus ?thesis by fast
qed
lemma abs_terms_subst_range_comp:
assumes "subst_range θ ∩ abs_terms = {}" "subst_range δ ∩ abs_terms = {}"
shows "subst_range (θ ∘⇩s δ) ∩ abs_terms = {}"
proof -
{ fix t f assume t: "t ∈ subst_range (θ ∘⇩s δ)" "f ∈ funs_term t" "is_Abs f"
then obtain x where x: "(θ ∘⇩s δ) x = t" by auto
have "θ x ∉ abs_terms" using assms(1) by (cases "θ x ∈ subst_range θ") force+
hence "(θ ∘⇩s δ) x ∉ abs_terms"
using assms(2) abs_terms_subst[of "θ x" δ] abs_terms_subst_range_disj
by (metis (mono_tags, lifting) subst_compose_def)
hence False using t(2,3) x by blast
} thus ?thesis by fast
qed
lemma abs_terms_subst_range_comp':
assumes "(θ ` X) ∩ abs_terms = {}" "(δ ` fv⇩s⇩e⇩t (θ ` X)) ∩ abs_terms = {}"
shows "((θ ∘⇩s δ) ` X) ∩ abs_terms = {}"
proof -
{ fix t f assume t:
"t ∈ (θ ∘⇩s δ) ` X" "f ∈ funs_term t" "is_Abs f"
then obtain x where x: "(θ ∘⇩s δ) x = t" "x ∈ X" by auto
have "θ x ∉ abs_terms" using assms(1) x(2) by force
moreover have "fv (θ x) ⊆ fv⇩s⇩e⇩t (θ ` X)" using x(2) by (auto simp add: fv_subset)
hence "δ ` fv (θ x) ∩ abs_terms = {}" using assms(2) by auto
ultimately have "(θ ∘⇩s δ) x ∉ abs_terms"
using abs_terms_subst[of "θ x" δ]
by (metis (mono_tags, lifting) subst_compose_def)
hence False using t(2,3) x by blast
} thus ?thesis by fast
qed
context
begin
private lemma Ana_abs_aux1:
fixes δ::"(('fun,'atom,'sets) prot_fun, nat, ('fun,'atom,'sets) prot_var) gsubst"
and α::"nat × bool ⇒ 'sets set"
assumes "Ana⇩f f = (K,T)"
shows "(K ⋅⇩l⇩i⇩s⇩t δ) ⋅⇩α⇩l⇩i⇩s⇩t α = K ⋅⇩l⇩i⇩s⇩t (λn. δ n ⋅⇩α α)"
proof -
{ fix k assume "k ∈ set K"
hence "k ∈ subterms⇩s⇩e⇩t (set K)" by force
hence "k ⋅ δ ⋅⇩α α = k ⋅ (λn. δ n ⋅⇩α α)"
proof (induction k)
case (Fun g S)
have "⋀s. s ∈ set S ⟹ s ⋅ δ ⋅⇩α α = s ⋅ (λn. δ n ⋅⇩α α)"
using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
by (meson contra_subsetD)
thus ?case using Ana⇩f_assm1_alt[OF assms Fun.prems] by (cases g) auto
qed simp
} thus ?thesis unfolding abs_apply_list_def by force
qed
private lemma Ana_abs_aux2:
fixes α::"nat × bool ⇒ 'sets set"
and K::"(('fun,'atom,'sets) prot_fun, nat) term list"
and M::"nat list"
and T::"('fun,'atom,'sets) prot_term list"
assumes "∀i ∈ fv⇩s⇩e⇩t (set K) ∪ set M. i < length T"
and "(K ⋅⇩l⇩i⇩s⇩t (!) T) ⋅⇩α⇩l⇩i⇩s⇩t α = K ⋅⇩l⇩i⇩s⇩t (λn. T ! n ⋅⇩α α)"
shows "(K ⋅⇩l⇩i⇩s⇩t (!) T) ⋅⇩α⇩l⇩i⇩s⇩t α = K ⋅⇩l⇩i⇩s⇩t (!) (map (λs. s ⋅⇩α α) T)" (is "?A1 = ?A2")
and "(map ((!) T) M) ⋅⇩α⇩l⇩i⇩s⇩t α = map ((!) (map (λs. s ⋅⇩α α) T)) M" (is "?B1 = ?B2")
proof -
have "T ! i ⋅⇩α α = (map (λs. s ⋅⇩α α) T) ! i" when "i ∈ fv⇩s⇩e⇩t (set K)" for i
using that assms(1) by auto
hence "k ⋅ (λi. T ! i ⋅⇩α α) = k ⋅ (λi. (map (λs. s ⋅⇩α α) T) ! i)" when "k ∈ set K" for k
using that term_subst_eq_conv[of k "λi. T ! i ⋅⇩α α" "λi. (map (λs. s ⋅⇩α α) T) ! i"]
by auto
thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)
have "T ! i ⋅⇩α α = map (λs. s ⋅⇩α α) T ! i" when "i ∈ set M" for i
using that assms(1) by auto
thus "?B1 = ?B2" by (force simp add: abs_apply_list_def)
qed
private lemma Ana_abs_aux1_set:
fixes δ::"(('fun,'atom,'sets) prot_fun, nat, ('fun,'atom,'sets) prot_var) gsubst"
and α::"nat × bool ⇒ 'sets set"
assumes "Ana⇩f f = (K,T)"
shows "(set K ⋅⇩s⇩e⇩t δ) ⋅⇩α⇩s⇩e⇩t α = set K ⋅⇩s⇩e⇩t (λn. δ n ⋅⇩α α)"
proof -
{ fix k assume "k ∈ set K"
hence "k ∈ subterms⇩s⇩e⇩t (set K)" by force
hence "k ⋅ δ ⋅⇩α α = k ⋅ (λn. δ n ⋅⇩α α)"
proof (induction k)
case (Fun g S)
have "⋀s. s ∈ set S ⟹ s ⋅ δ ⋅⇩α α = s ⋅ (λn. δ n ⋅⇩α α)"
using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
by (meson contra_subsetD)
thus ?case using Ana⇩f_assm1_alt[OF assms Fun.prems] by (cases g) auto
qed simp
} thus ?thesis unfolding abs_apply_terms_def by force
qed
private lemma Ana_abs_aux2_set:
fixes α::"nat × bool ⇒ 'sets set"
and K::"(('fun,'atom,'sets) prot_fun, nat) terms"
and M::"nat set"
and T::"('fun,'atom,'sets) prot_term list"
assumes "∀i ∈ fv⇩s⇩e⇩t K ∪ M. i < length T"
and "(K ⋅⇩s⇩e⇩t (!) T) ⋅⇩α⇩s⇩e⇩t α = K ⋅⇩s⇩e⇩t (λn. T ! n ⋅⇩α α)"
shows "(K ⋅⇩s⇩e⇩t (!) T) ⋅⇩α⇩s⇩e⇩t α = K ⋅⇩s⇩e⇩t (!) (map (λs. s ⋅⇩α α) T)" (is "?A1 = ?A2")
and "((!) T ` M) ⋅⇩α⇩s⇩e⇩t α = (!) (map (λs. s ⋅⇩α α) T) ` M" (is "?B1 = ?B2")
proof -
have "T ! i ⋅⇩α α = (map (λs. s ⋅⇩α α) T) ! i" when "i ∈ fv⇩s⇩e⇩t K" for i
using that assms(1) by auto
hence "k ⋅ (λi. T ! i ⋅⇩α α) = k ⋅ (λi. (map (λs. s ⋅⇩α α) T) ! i)" when "k ∈ K" for k
using that term_subst_eq_conv[of k "λi. T ! i ⋅⇩α α" "λi. (map (λs. s ⋅⇩α α) T) ! i"]
by auto
thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)
have "T ! i ⋅⇩α α = map (λs. s ⋅⇩α α) T ! i" when "i ∈ M" for i
using that assms(1) by auto
thus "?B1 = ?B2" by (force simp add: abs_apply_terms_def)
qed
lemma Ana_abs:
fixes t::"('fun,'atom,'sets) prot_term"
assumes "Ana t = (K, T)"
shows "Ana (t ⋅⇩α α) = (K ⋅⇩α⇩l⇩i⇩s⇩t α, T ⋅⇩α⇩l⇩i⇩s⇩t α)"
using assms
proof (induction t rule: Ana.induct)
case (1 f S)
obtain K' T' where *: "Ana⇩f f = (K',T')" by moura
show ?case using 1
proof (cases "arity⇩f f = length S ∧ arity⇩f f > 0")
case True
hence "K = K' ⋅⇩l⇩i⇩s⇩t (!) S" "T = map ((!) S) T'"
and **: "arity⇩f f = length (map (λs. s ⋅⇩α α) S)" "arity⇩f f > 0"
using 1 * by auto
hence "K ⋅⇩α⇩l⇩i⇩s⇩t α = K' ⋅⇩l⇩i⇩s⇩t (!) (map (λs. s ⋅⇩α α) S)"
"T ⋅⇩α⇩l⇩i⇩s⇩t α = map ((!) (map (λs. s ⋅⇩α α) S)) T'"
using Ana⇩f_assm2_alt[OF *] Ana_abs_aux2[OF _ Ana_abs_aux1[OF *], of T' S α]
unfolding abs_apply_list_def
by auto
moreover have "Fun (Fu f) S ⋅⇩α α = Fun (Fu f) (map (λs. s ⋅⇩α α) S)" by simp
ultimately show ?thesis using Ana_Fu_intro[OF ** *] by metis
qed (auto simp add: abs_apply_list_def)
qed (simp_all add: abs_apply_list_def)
end
lemma deduct_FP_if_deduct:
fixes M IK FP::"('fun,'atom,'sets) prot_terms"
assumes IK: "IK ⊆ GSMP M - (pubval_terms ∪ abs_terms)" "∀t ∈ IK ⋅⇩α⇩s⇩e⇩t α. FP ⊢⇩c t"
and t: "IK ⊢ t" "t ∈ GSMP M - (pubval_terms ∪ abs_terms)"
shows "FP ⊢ t ⋅⇩α α"
proof -
let ?P = "λf. is_Val f ⟶ ¬public f"
let ?GSMP = "GSMP M - (pubval_terms ∪ abs_terms)"
have 1: "∀m ∈ IK. m ∈ ?GSMP"
using IK(1) by blast
have 2: "∀t t'. t ∈ ?GSMP ⟶ t' ⊑ t ⟶ t' ∈ ?GSMP"
proof (intro allI impI)
fix t t' assume t: "t ∈ ?GSMP" "t' ⊑ t"
hence "t' ∈ GSMP M" using ground_subterm unfolding GSMP_def by auto
moreover have "¬public f"
when "f ∈ funs_term t" "is_Val f" for f
using t(1) that by auto
hence "¬public f"
when "f ∈ funs_term t'" "is_Val f" for f
using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
moreover have "¬is_Abs f" when "f ∈ funs_term t" for f using t(1) that by auto
hence "¬is_Abs f" when "f ∈ funs_term t'" for f
using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
ultimately show "t' ∈ ?GSMP" by simp
qed
have 3: "∀t K T k. t ∈ ?GSMP ⟶ Ana t = (K, T) ⟶ k ∈ set K ⟶ k ∈ ?GSMP"
proof (intro allI impI)
fix t K T k assume t: "t ∈ ?GSMP" "Ana t = (K, T)" "k ∈ set K"
hence "k ∈ GSMP M" using GSMP_Ana_key by blast
moreover have "∀f ∈ funs_term t. ?P f" using t(1) by auto
with t(2,3) have "∀f ∈ funs_term k. ?P f"
proof (induction t arbitrary: k rule: Ana.induct)
case 1 thus ?case by (metis Ana_Fu_keys_not_pubval_terms surj_pair)
qed auto
moreover have "∀f ∈ funs_term t. ¬is_Abs f" using t(1) by auto
with t(2,3) have "∀f ∈ funs_term k. ¬is_Abs f"
proof (induction t arbitrary: k rule: Ana.induct)
case 1 thus ?case by (metis Ana_Fu_keys_not_abs_terms surj_pair)
qed auto
ultimately show "k ∈ ?GSMP" by simp
qed
have "⟨IK; M⟩ ⊢⇩G⇩S⇩M⇩P t"
unfolding intruder_deduct_GSMP_def
by (rule restricted_deduct_if_deduct'[OF 1 2 3 t])
thus ?thesis
proof (induction t rule: intruder_deduct_GSMP_induct)
case (AxiomH t)
show ?case using IK(2) abs_in[OF AxiomH.hyps] by force
next
case (ComposeH T f)
have *: "Fun f T ⋅⇩α α = Fun f (map (λt. t ⋅⇩α α) T)"
using ComposeH.hyps(2,4)
by (cases f) auto
have **: "length (map (λt. t ⋅⇩α α) T) = arity f"
using ComposeH.hyps(1)
by auto
show ?case
using intruder_deduct.Compose[OF ** ComposeH.hyps(2)] ComposeH.IH(1) *
by auto
next
case (DecomposeH t K T' t⇩i)
have *: "Ana (t ⋅⇩α α) = (K ⋅⇩α⇩l⇩i⇩s⇩t α, T' ⋅⇩α⇩l⇩i⇩s⇩t α)"
using Ana_abs[OF DecomposeH.hyps(2)]
by metis
have **: "t⇩i ⋅⇩α α ∈ set (T' ⋅⇩α⇩l⇩i⇩s⇩t α)"
using DecomposeH.hyps(4) abs_in abs_list_set_is_set_abs_set[of T']
by auto
have ***: "FP ⊢ k"
when k: "k ∈ set (K ⋅⇩α⇩l⇩i⇩s⇩t α)" for k
proof -
obtain k' where k': "k' ∈ set K" "k = k' ⋅⇩α α"
by (metis (no_types) k abs_apply_terms_def imageE abs_list_set_is_set_abs_set)
show "FP ⊢ k"
using DecomposeH.IH k' by blast
qed
show ?case
using intruder_deduct.Decompose[OF _ * _ **]
DecomposeH.IH(1) ***(1)
by blast
qed
qed
end
subsection ‹Computing and Checking Term Implications and Messages›
context stateful_protocol_model
begin
abbreviation (input) "absc s ≡ (Fun (Abs s) []::('fun, 'atom, 'sets) prot_term)"
fun absdbupd where
"absdbupd [] _ a = a"
| "absdbupd (insert⟨Var y, Fun (Set s) T⟩#D) x a = (
if x = y then absdbupd D x (insert s a) else absdbupd D x a)"
| "absdbupd (delete⟨Var y, Fun (Set s) T⟩#D) x a = (
if x = y then absdbupd D x (a - {s}) else absdbupd D x a)"
| "absdbupd (_#D) x a = absdbupd D x a"
lemma absdbupd_cons_cases:
"absdbupd (insert⟨Var x, Fun (Set s) T⟩#D) x d = absdbupd D x (insert s d)"
"absdbupd (delete⟨Var x, Fun (Set s) T⟩#D) x d = absdbupd D x (d - {s})"
"t ≠ Var x ∨ (∄s T. u = Fun (Set s) T) ⟹ absdbupd (insert⟨t,u⟩#D) x d = absdbupd D x d"
"t ≠ Var x ∨ (∄s T. u = Fun (Set s) T) ⟹ absdbupd (delete⟨t,u⟩#D) x d = absdbupd D x d"
proof -
assume *: "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)"
let ?P = "absdbupd (insert⟨t,u⟩#D) x d = absdbupd D x d"
let ?Q = "absdbupd (delete⟨t,u⟩#D) x d = absdbupd D x d"
{ fix y f T assume "t = Fun f T ∨ u = Var y" hence ?P ?Q by auto
} moreover {
fix y f T assume "t = Var y" "u = Fun f T" hence ?P using * by (cases f) auto
} moreover {
fix y f T assume "t = Var y" "u = Fun f T" hence ?Q using * by (cases f) auto
} ultimately show ?P ?Q by (metis term.exhaust)+
qed simp_all
lemma absdbupd_filter: "absdbupd S x d = absdbupd (filter is_Update S) x d"
by (induction S x d rule: absdbupd.induct) simp_all
lemma absdbupd_append:
"absdbupd (A@B) x d = absdbupd B x (absdbupd A x d)"
proof (induction A arbitrary: d)
case (Cons a A) thus ?case
proof (cases a)
case (Insert t u) thus ?thesis
proof (cases "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)")
case False
then obtain s T where "t = Var x" "u = Fun (Set s) T" by moura
thus ?thesis by (simp add: Insert Cons.IH absdbupd_cons_cases(1))
qed (simp_all add: Cons.IH absdbupd_cons_cases(3))
next
case (Delete t u) thus ?thesis
proof (cases "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)")
case False
then obtain s T where "t = Var x" "u = Fun (Set s) T" by moura
thus ?thesis by (simp add: Delete Cons.IH absdbupd_cons_cases(2))
qed (simp_all add: Cons.IH absdbupd_cons_cases(4))
qed simp_all
qed simp
lemma absdbupd_wellformed_transaction:
assumes T: "wellformed_transaction T"
shows "absdbupd (unlabel (transaction_strand T)) = absdbupd (unlabel (transaction_updates T))"
proof -
define S0 where "S0 ≡ unlabel (transaction_strand T)"
define S1 where "S1 ≡ unlabel (transaction_receive T)"
define S2 where "S2 ≡ unlabel (transaction_selects T)"
define S3 where "S3 ≡ unlabel (transaction_checks T)"
define S4 where "S4 ≡ unlabel (transaction_updates T)"
define S5 where "S5 ≡ unlabel (transaction_send T)"
note S_defs = S0_def S1_def S2_def S3_def S4_def S5_def
have 0: "list_all is_Receive S1"
"list_all is_Assignment S2"
"list_all is_Check S3"
"list_all is_Update S4"
"list_all is_Send S5"
using T unfolding wellformed_transaction_def S_defs by metis+
have "filter is_Update S1 = []"
"filter is_Update S2 = []"
"filter is_Update S3 = []"
"filter is_Update S4 = S4"
"filter is_Update S5 = []"
using list_all_filter_nil[OF 0(1), of is_Update]
list_all_filter_nil[OF 0(2), of is_Update]
list_all_filter_nil[OF 0(3), of is_Update]
list_all_filter_eq[OF 0(4)]
list_all_filter_nil[OF 0(5), of is_Update]
by blast+
moreover have "S0 = S1@S2@S3@S4@S5"
unfolding S_defs transaction_strand_def unlabel_def by auto
ultimately have "filter is_Update S0 = S4"
using filter_append[of is_Update] list_all_append[of is_Update]
by simp
thus ?thesis
using absdbupd_filter[of S0]
unfolding S_defs by presburger
qed
fun abs_substs_set::
"[('fun,'atom,'sets) prot_var list,
'sets set list,
('fun,'atom,'sets) prot_var ⇒ 'sets set,
('fun,'atom,'sets) prot_var ⇒ 'sets set]
⇒ ((('fun,'atom,'sets) prot_var × 'sets set) list) list"
where
"abs_substs_set [] _ _ _ = [[]]"
| "abs_substs_set (x#xs) as posconstrs negconstrs = (
let bs = filter (λa. posconstrs x ⊆ a ∧ a ∩ negconstrs x = {}) as
in concat (map (λb. map (λδ. (x, b)#δ) (abs_substs_set xs as posconstrs negconstrs)) bs))"
definition abs_substs_fun::
"[(('fun,'atom,'sets) prot_var × 'sets set) list,
('fun,'atom,'sets) prot_var]
⇒ 'sets set"
where
"abs_substs_fun δ x = (case find (λb. fst b = x) δ of Some (_,a) ⇒ a | None ⇒ {})"
lemmas abs_substs_set_induct = abs_substs_set.induct[case_names Nil Cons]
fun transaction_poschecks_comp::
"(('fun,'atom,'sets) prot_fun, ('fun,'atom,'sets) prot_var) stateful_strand
⇒ (('fun,'atom,'sets) prot_var ⇒ 'sets set)"
where
"transaction_poschecks_comp [] = (λ_. {})"
| "transaction_poschecks_comp (⟨_: Var x ∈ Fun (Set s) []⟩#T) = (
let f = transaction_poschecks_comp T in f(x := insert s (f x)))"
| "transaction_poschecks_comp (_#T) = transaction_poschecks_comp T"
fun transaction_negchecks_comp::
"(('fun,'atom,'sets) prot_fun, ('fun,'atom,'sets) prot_var) stateful_strand
⇒ (('fun,'atom,'sets) prot_var ⇒ 'sets set)"
where
"transaction_negchecks_comp [] = (λ_. {})"
| "transaction_negchecks_comp (⟨Var x not in Fun (Set s) []⟩#T) = (
let f = transaction_negchecks_comp T in f(x := insert s (f x)))"
| "transaction_negchecks_comp (_#T) = transaction_negchecks_comp T"
definition transaction_check_pre where
"transaction_check_pre FP TI T δ ≡
let C = set (unlabel (transaction_checks T));
S = set (unlabel (transaction_selects T));
xs = fv_list⇩s⇩s⇩t (unlabel (transaction_strand T));
θ = λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x
in (∀x ∈ set (transaction_fresh T). δ x = {}) ∧
(∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ δ)) ∧
(∀u ∈ S ∪ C.
(is_InSet u ⟶ (
let x = the_elem_term u; s = the_set_term u
in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∈ δ (the_Var x))) ∧
((is_NegChecks u ∧ bvars⇩s⇩s⇩t⇩p u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1) ⟶ (
let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∉ δ (the_Var x))))"
definition transaction_check_post where
"transaction_check_post FP TI T δ ≡
let xs = fv_list⇩s⇩s⇩t (unlabel (transaction_strand T));
θ = λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x;
u = λδ x. absdbupd (unlabel (transaction_updates T)) x (δ x)
in (∀x ∈ set xs - set (transaction_fresh T). δ x ≠ u δ x ⟶ List.member TI (δ x, u δ x)) ∧
(∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T). intruder_synth_mod_timpls FP TI (t ⋅ θ (u δ)))"
definition transaction_check_comp::
"[('fun,'atom,'sets) prot_term list,
'sets set list,
('sets set × 'sets set) list,
('fun,'atom,'sets,'lbl) prot_transaction]
⇒ ((('fun,'atom,'sets) prot_var × 'sets set) list) list"
where
"transaction_check_comp FP OCC TI T ≡
let S = unlabel (transaction_strand T);
C = unlabel (transaction_selects T@transaction_checks T);
xs = filter (λx. x ∉ set (transaction_fresh T) ∧ fst x = TAtom Value) (fv_list⇩s⇩s⇩t S);
posconstrs = transaction_poschecks_comp C;
negconstrs = transaction_negchecks_comp C;
pre_check = transaction_check_pre FP TI T
in filter (λδ. pre_check (abs_substs_fun δ)) (abs_substs_set xs OCC posconstrs negconstrs)"
definition transaction_check::
"[('fun,'atom,'sets) prot_term list,
'sets set list,
('sets set × 'sets set) list,
('fun,'atom,'sets,'lbl) prot_transaction]
⇒ bool"
where
"transaction_check FP OCC TI T ≡
list_all (λδ. transaction_check_post FP TI T (abs_substs_fun δ)) (transaction_check_comp FP OCC TI T)"
lemma abs_subst_fun_cons:
"abs_substs_fun ((x,b)#δ) = (abs_substs_fun δ)(x := b)"
unfolding abs_substs_fun_def by fastforce
lemma abs_substs_cons:
assumes "δ ∈ set (abs_substs_set xs as poss negs)" "b ∈ set as" "poss x ⊆ b" "b ∩ negs x = {}"
shows "(x,b)#δ ∈ set (abs_substs_set (x#xs) as poss negs)"
using assms by auto
lemma abs_substs_cons':
assumes δ: "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)"
and b: "b ∈ set as" "poss x ⊆ b" "b ∩ negs x = {}"
shows "δ(x := b) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs)"
proof -
obtain θ where θ: "δ = abs_substs_fun θ" "θ ∈ set (abs_substs_set xs as poss negs)"
using δ by moura
have "abs_substs_fun ((x, b)#θ) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs)"
using abs_substs_cons[OF θ(2) b] by blast
thus ?thesis
using θ(1) abs_subst_fun_cons[of x b θ] by argo
qed
lemma abs_substs_has_all_abs:
assumes "∀x. x ∈ set xs ⟶ δ x ∈ set as"
and "∀x. x ∈ set xs ⟶ poss x ⊆ δ x"
and "∀x. x ∈ set xs ⟶ δ x ∩ negs x = {}"
and "∀x. x ∉ set xs ⟶ δ x = {}"
shows "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)"
using assms
proof (induction xs arbitrary: δ)
case (Cons x xs)
define θ where "θ ≡ λy. if y ∈ set xs then δ y else {}"
have "θ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)"
using Cons.prems Cons.IH by (simp add: θ_def)
moreover have "δ x ∈ set as" "poss x ⊆ δ x" "δ x ∩ negs x = {}"
using Cons.prems(1,2,3) by fastforce+
ultimately have 0: "θ(x := δ x) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs)"
by (metis abs_substs_cons')
have "δ = θ(x := δ x)"
proof
fix y show "δ y = (θ(x := δ x)) y"
proof (cases "y ∈ set (x#xs)")
case False thus ?thesis using Cons.prems(4) by (fastforce simp add: θ_def)
qed (auto simp add: θ_def)
qed
thus ?case by (metis 0)
qed (auto simp add: abs_substs_fun_def)
lemma abs_substs_abss_bounded:
assumes "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)"
and "x ∈ set xs"
shows "δ x ∈ set as"
and "poss x ⊆ δ x"
and "δ x ∩ negs x = {}"
using assms
proof (induct xs as poss negs arbitrary: δ rule: abs_substs_set_induct)
case (Cons y xs as poss negs)
{ case 1 thus ?case using Cons.hyps(1) unfolding abs_substs_fun_def by fastforce }
{ case 2 thus ?case
proof (cases "x = y")
case False
then obtain δ' where δ':
"δ' ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)" "δ' x = δ x"
using 2 unfolding abs_substs_fun_def by force
moreover have "x ∈ set xs" using 2(2) False by simp
moreover have "∃b. b ∈ set as ∧ poss y ⊆ b ∧ b ∩ negs y = {}"
using 2 False by auto
ultimately show ?thesis using Cons.hyps(2) by fastforce
qed (auto simp add: abs_substs_fun_def)
}
{ case 3 thus ?case
proof (cases "x = y")
case False
then obtain δ' where δ':
"δ' ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs)" "δ' x = δ x"
using 3 unfolding abs_substs_fun_def by force
moreover have "x ∈ set xs" using 3(2) False by simp
moreover have "∃b. b ∈ set as ∧ poss y ⊆ b ∧ b ∩ negs y = {}"
using 3 False by auto
ultimately show ?thesis using Cons.hyps(3) by fastforce
qed (auto simp add: abs_substs_fun_def)
}
qed (simp_all add: abs_substs_fun_def)
lemma transaction_poschecks_comp_unfold:
"transaction_poschecks_comp C x = {s. ∃a. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ set C}"
proof (induction C)
case (Cons c C) thus ?case
proof (cases "∃a y s. c = ⟨a: Var y ∈ Fun (Set s) []⟩")
case True
then obtain a y s where c: "c = ⟨a: Var y ∈ Fun (Set s) []⟩" by moura
define f where "f ≡ transaction_poschecks_comp C"
have "transaction_poschecks_comp (c#C) = f(y := insert s (f y))"
using c by (simp add: f_def Let_def)
moreover have "f x = {s. ∃a. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ set C}"
using Cons.IH unfolding f_def by blast
ultimately show ?thesis using c by auto
next
case False
hence "transaction_poschecks_comp (c#C) = transaction_poschecks_comp C" (is ?P)
using transaction_poschecks_comp.cases[of "c#C" ?P] by force
thus ?thesis using False Cons.IH by auto
qed
qed simp
lemma transaction_poschecks_comp_notin_fv_empty:
assumes "x ∉ fv⇩s⇩s⇩t C"
shows "transaction_poschecks_comp C x = {}"
using assms transaction_poschecks_comp_unfold[of C x] by fastforce
lemma transaction_negchecks_comp_unfold:
"transaction_negchecks_comp C x = {s. ⟨Var x not in Fun (Set s) []⟩ ∈ set C}"
proof (induction C)
case (Cons c C) thus ?case
proof (cases "∃y s. c = ⟨Var y not in Fun (Set s) []⟩")
case True
then obtain y s where c: "c = ⟨Var y not in Fun (Set s) []⟩" by moura
define f where "f ≡ transaction_negchecks_comp C"
have "transaction_negchecks_comp (c#C) = f(y := insert s (f y))"
using c by (simp add: f_def Let_def)
moreover have "f x = {s. ⟨Var x not in Fun (Set s) []⟩ ∈ set C}"
using Cons.IH unfolding f_def by blast
ultimately show ?thesis using c by auto
next
case False
hence "transaction_negchecks_comp (c#C) = transaction_negchecks_comp C" (is ?P)
using transaction_negchecks_comp.cases[of "c#C" ?P]
by force
thus ?thesis using False Cons.IH by fastforce
qed
qed simp
lemma transaction_negchecks_comp_notin_fv_empty:
assumes "x ∉ fv⇩s⇩s⇩t C"
shows "transaction_negchecks_comp C x = {}"
using assms transaction_negchecks_comp_unfold[of C x] by fastforce
lemma transaction_check_preI[intro]:
fixes T
defines "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
and "S ≡ set (unlabel (transaction_selects T))"
and "C ≡ set (unlabel (transaction_checks T))"
assumes a0: "∀x ∈ set (transaction_fresh T). δ x = {}"
and a1: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ δ x ∈ set OCC"
and a2: "∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ δ)"
and a3: "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∈ δ x"
and a4: "∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∉ δ x"
shows "transaction_check_pre FP TI T δ"
proof -
let ?P = "λu. is_InSet u ⟶ (
let x = the_elem_term u; s = the_set_term u
in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∈ δ (the_Var x))"
let ?Q = "λu. (is_NegChecks u ∧ bvars⇩s⇩s⇩t⇩p u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1) ⟶ (
let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∉ δ (the_Var x))"
have 1: "?P u" when u: "u ∈ S ∪ C" for u
apply (unfold Let_def, intro impI, elim conjE)
using u a3 Fun_Set_InSet_iff[of u] by metis
have 2: "?Q u" when u: "u ∈ S ∪ C" for u
apply (unfold Let_def, intro impI, elim conjE)
using u a4 Fun_Set_NotInSet_iff[of u] by metis
show ?thesis
using a0 a1 a2 1 2 fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t[of "unlabel (transaction_strand T)"]
unfolding transaction_check_pre_def θ_def S_def C_def Let_def
by blast
qed
lemma transaction_check_pre_InSetE:
assumes T: "transaction_check_pre FP TI T δ"
and u: "u = ⟨a: Var x ∈ Fun (Set s) []⟩"
"u ∈ set (unlabel (transaction_selects T)) ∪ set (unlabel (transaction_checks T))"
shows "s ∈ δ x"
proof -
have "is_InSet u ⟶ is_Var (the_elem_term u) ∧ is_Fun_Set (the_set_term u) ⟶
the_Set (the_Fun (the_set_term u)) ∈ δ (the_Var (the_elem_term u))"
using T u unfolding transaction_check_pre_def Let_def by blast
thus ?thesis using Fun_Set_InSet_iff[of u a x s] u by argo
qed
lemma transaction_check_pre_NotInSetE:
assumes T: "transaction_check_pre FP TI T δ"
and u: "u = ⟨Var x not in Fun (Set s) []⟩"
"u ∈ set (unlabel (transaction_selects T)) ∪ set (unlabel (transaction_checks T))"
shows "s ∉ δ x"
proof -
have "is_NegChecks u ∧ bvars⇩s⇩s⇩t⇩p u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1 ⟶
is_Var (fst (hd (the_ins u))) ∧ is_Fun_Set (snd (hd (the_ins u))) ⟶
the_Set (the_Fun (snd (hd (the_ins u)))) ∉ δ (the_Var (fst (hd (the_ins u))))"
using T u unfolding transaction_check_pre_def Let_def by blast
thus ?thesis using Fun_Set_NotInSet_iff[of u x s] u by argo
qed
lemma transaction_check_compI[intro]:
assumes T: "transaction_check_pre FP TI T δ"
and T_adm: "admissible_transaction T"
and x1: "∀x. (x ∈ fv_transaction T - set (transaction_fresh T) ∧ fst x = TAtom Value)
⟶ δ x ∈ set OCC"
and x2: "∀x. (x ∉ fv_transaction T - set (transaction_fresh T) ∨ fst x ≠ TAtom Value)
⟶ δ x = {}"
shows "δ ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
proof -
define S where "S ≡ unlabel (transaction_strand T)"
define C where "C ≡ unlabel (transaction_selects T@transaction_checks T)"
define C' where "C' ≡ set (unlabel (transaction_selects T)) ∪
set (unlabel (transaction_checks T))"
let ?xs = "fv_list⇩s⇩s⇩t S"
define poss where "poss ≡ transaction_poschecks_comp C"
define negs where "negs ≡ transaction_negchecks_comp C"
define ys where "ys ≡ filter (λx. x ∉ set (transaction_fresh T) ∧ fst x = TAtom Value) ?xs"
have C_C'_eq: "set C = C'"
using unlabel_append[of "transaction_selects T" "transaction_checks T"]
unfolding C_def C'_def by simp
have ys: "{x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value} = set ys"
using fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t[of S]
unfolding ys_def S_def by force
have "δ x ∈ set OCC"
when x: "x ∈ set ys" for x
using x1 x ys by blast
moreover have "δ x = {}"
when x: "x ∉ set ys" for x
using x2 x ys by blast
moreover have "poss x ⊆ δ x" when x: "x ∈ set ys" for x
proof -
have "s ∈ δ x" when u: "u = ⟨a: Var x ∈ Fun (Set s) []⟩" "u ∈ C'" for u a s
using T u transaction_check_pre_InSetE[of FP TI T δ]
unfolding C'_def by blast
thus ?thesis
using transaction_poschecks_comp_unfold[of C x] C_C'_eq
unfolding poss_def by blast
qed
moreover have "δ x ∩ negs x = {}" when x: "x ∈ set ys" for x
proof (cases "x ∈ fv⇩s⇩s⇩t C")
case True
hence "s ∉ δ x" when u: "u = ⟨Var x not in Fun (Set s) []⟩" "u ∈ C'" for u s
using T u transaction_check_pre_NotInSetE[of FP TI T δ]
unfolding C'_def by blast
thus ?thesis
using transaction_negchecks_comp_unfold[of C x] C_C'_eq
unfolding negs_def by blast
next
case False
hence "negs x = {}"
using x C_C'_eq transaction_negchecks_comp_notin_fv_empty
unfolding negs_def by blast
thus ?thesis by blast
qed
ultimately have "δ ∈ abs_substs_fun ` set (abs_substs_set ys OCC poss negs)"
using abs_substs_has_all_abs[of ys δ OCC poss negs]
by fast
thus ?thesis
using T
unfolding transaction_check_comp_def Let_def S_def C_def ys_def poss_def negs_def
by fastforce
qed
context
begin
private lemma transaction_check_comp_in_aux:
fixes T
defines "S ≡ set (unlabel (transaction_selects T))"
and "C ≡ set (unlabel (transaction_checks T))"
assumes T_adm: "admissible_transaction T"
and a1: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
select⟨Var x, Fun (Set s) []⟩ ∈ S ⟶ s ∈ α x)"
and a2: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x)"
and a3: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α x)"
shows "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∈ α x" (is ?A)
and "∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∉ α x" (is ?B)
proof -
have T_valid: "wellformed_transaction T"
and T_adm_S: "admissible_transaction_selects T"
and T_adm_C: "admissible_transaction_checks T"
using T_adm unfolding admissible_transaction_def by blast+
note * = admissible_transaction_strand_step_cases(2,3)[OF T_adm]
have 1: "fst x = TAtom Value" "x ∈ fv_transaction T - set (transaction_fresh T)"
when x: "⟨a: Var x ∈ Fun (Set s) []⟩ ∈ S ∪ C" for a x s
using * x unfolding S_def C_def by fast+
have 2: "fst x = TAtom Value" "x ∈ fv_transaction T - set (transaction_fresh T)"
when x: "⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C" for x s
using * x unfolding S_def C_def by fast+
have 3: "select⟨Var x, Fun (Set s) []⟩ ∈ S"
when x: "select⟨Var x, Fun (Set s) []⟩ ∈ S ∪ C" for x s
using * x unfolding S_def C_def by fast
have 4: "⟨Var x in Fun (Set s) []⟩ ∈ C"
when x: "⟨Var x in Fun (Set s) []⟩ ∈ S ∪ C" for x s
using * x unfolding S_def C_def by fast
have 5: "⟨Var x not in Fun (Set s) []⟩ ∈ C"
when x: "⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C" for x s
using * x unfolding S_def C_def by fast
show ?A
proof (intro allI impI)
fix a x s assume u: "⟨a: Var x ∈ Fun (Set s) []⟩ ∈ S ∪ C"
thus "s ∈ α x" using 1 3 4 a1 a2 by (cases a) metis+
qed
show ?B
proof (intro allI impI)
fix x s assume u: "⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C"
thus "s ∉ α x" using 2 5 a3 by meson
qed
qed
lemma transaction_check_comp_in:
fixes T
defines "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
and "S ≡ set (unlabel (transaction_selects T))"
and "C ≡ set (unlabel (transaction_checks T))"
assumes T_adm: "admissible_transaction T"
and a1: "∀x ∈ set (transaction_fresh T). α x = {}"
and a2: "∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ α)"
and a3: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
select⟨Var x, Fun (Set s) []⟩ ∈ S ⟶ s ∈ α x"
and a4: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x"
and a5: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α x"
and a6: "∀x ∈ fv_transaction T - set (transaction_fresh T).
fst x = TAtom Value ⟶ α x ∈ set OCC"
shows "∃δ ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T). ∀x ∈ fv_transaction T.
fst x = TAtom Value ⟶ α x = δ x"
proof -
let ?xs = "fv_list⇩s⇩s⇩t (unlabel (transaction_strand T))"
let ?ys = "filter (λx. x ∉ set (transaction_fresh T)) ?xs"
define α' where "α' ≡ λx.
if x ∈ fv_transaction T - set (transaction_fresh T) ∧ fst x = TAtom Value
then α x
else {}"
have T_valid: "wellformed_transaction T"
using T_adm unfolding admissible_transaction_def by blast
have θα_Fun: "is_Fun (t ⋅ θ α) ⟷ is_Fun (t ⋅ θ α')" for t
unfolding α'_def θ_def
by (induct t) auto
have "∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ α')"
proof (intro ballI impI)
fix t assume t: "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T)"
have 1: "intruder_synth_mod_timpls FP TI (t ⋅ θ α)"
using t a2
by auto
obtain r where r:
"r ∈ set (unlabel (transaction_receive T))"
"t ∈ trms⇩s⇩s⇩t⇩p r"
using t by auto
hence "r = receive⟨t⟩"
using wellformed_transaction_unlabel_cases(1)[OF T_valid]
by fastforce
hence 2: "fv t ⊆ fv⇩l⇩s⇩s⇩t (transaction_receive T)" using r by force
have "fv t ⊆ fv_transaction T"
by (metis (no_types, lifting) 2 transaction_strand_def sst_vars_append_subset(1)
unlabel_append subset_Un_eq sup.bounded_iff)
moreover have "fv t ∩ set (transaction_fresh T) = {}"
using 2 T_valid vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel (transaction_receive T)"]
unfolding wellformed_transaction_def
by fast
ultimately have "θ α x = θ α' x" when "x ∈ fv t" for x
using that unfolding α'_def θ_def by fastforce
hence 3: "t ⋅ θ α = t ⋅ θ α'"
using term_subst_eq by blast
show "intruder_synth_mod_timpls FP TI (t ⋅ θ α')" using 1 3 by simp
qed
moreover have
"∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
select⟨Var x, Fun (Set s) []⟩ ∈ S ⟶ s ∈ α' x)"
"∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α' x)"
"∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α' x)"
using a3 a4 a5
unfolding α'_def θ_def S_def C_def
by meson+
hence "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∈ α' x"
"∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ S ∪ C ⟶ s ∉ α' x"
using transaction_check_comp_in_aux[OF T_adm, of α']
unfolding S_def C_def
by fast+
ultimately have 4: "transaction_check_pre FP TI T α'"
using a6 transaction_check_preI[of T α' OCC FP TI]
unfolding α'_def θ_def S_def C_def by simp
have 5: "∀x ∈ fv_transaction T. fst x = TAtom Value ⟶ α x = α' x"
using a1 by (auto simp add: α'_def)
have 6: "α' ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
using transaction_check_compI[OF 4 T_adm] a6
unfolding α'_def
by auto
show ?thesis using 5 6 by blast
qed
end
end
subsection ‹Automatically Checking Protocol Security in a Typed Model›
context stateful_protocol_model
begin
definition abs_intruder_knowledge ("α⇩i⇩k") where
"α⇩i⇩k S ℐ ≡ (ik⇩l⇩s⇩s⇩t S ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t S ℐ)"
definition abs_value_constants ("α⇩v⇩a⇩l⇩s") where
"α⇩v⇩a⇩l⇩s S ℐ ≡ {t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S) ⋅⇩s⇩e⇩t ℐ. ∃n. t = Fun (Val n) []} ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t S ℐ)"
definition abs_term_implications ("α⇩t⇩i") where
"α⇩t⇩i 𝒜 T σ α ℐ ≡ {(s,t) | s t x.
s ≠ t ∧ x ∈ fv_transaction T ∧ x ∉ set (transaction_fresh T) ∧
Fun (Abs s) [] = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) ∧
Fun (Abs t) [] = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ)}"
lemma abs_intruder_knowledge_append:
"α⇩i⇩k (A@B) ℐ =
(ik⇩l⇩s⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t (A@B) ℐ) ∪
(ik⇩l⇩s⇩s⇩t B ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t (A@B) ℐ)"
by (metis unlabel_append abs_set_union image_Un ik⇩s⇩s⇩t_append abs_intruder_knowledge_def)
lemma abs_value_constants_append:
fixes A B::"('a,'b,'c,'d) prot_strand"
shows "α⇩v⇩a⇩l⇩s (A@B) ℐ =
{t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ. ∃n. t = Fun (Val n) []} ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t (A@B) ℐ) ∪
{t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B) ⋅⇩s⇩e⇩t ℐ. ∃n. t = Fun (Val n) []} ⋅⇩α⇩s⇩e⇩t α⇩0 (db⇩l⇩s⇩s⇩t (A@B) ℐ)"
proof -
define a0 where "a0 ≡ α⇩0 (db⇩s⇩s⇩t (unlabel (A@B)) ℐ)"
define M where "M ≡ λa::('a,'b,'c,'d) prot_strand.
{t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t a) ⋅⇩s⇩e⇩t ℐ. ∃n. t = Fun (Val n) []}"
have "M (A@B) = M A ∪ M B"
using unlabel_append[of A B] trms⇩s⇩s⇩t_append[of "unlabel A" "unlabel B"]
image_Un[of "λx. x ⋅ ℐ" "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t A)" "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"]
unfolding M_def by force
hence "M (A@B) ⋅⇩α⇩s⇩e⇩t a0 = (M A ⋅⇩α⇩s⇩e⇩t a0) ∪ (M B ⋅⇩α⇩s⇩e⇩t a0)" by (simp add: abs_set_union)
thus ?thesis unfolding abs_value_constants_def a0_def M_def by blast
qed
lemma transaction_renaming_subst_has_no_pubconsts_abss:
fixes α::"('fun,'atom,'sets) prot_subst"
assumes "transaction_renaming_subst α P A"
shows "subst_range α ∩ pubval_terms = {}" (is ?A)
and "subst_range α ∩ abs_terms = {}" (is ?B)
proof -
{ fix t assume "t ∈ subst_range α"
then obtain x where "t = Var x"
using transaction_renaming_subst_is_renaming[OF assms]
by force
hence "t ∉ pubval_terms" "t ∉ abs_terms" by simp_all
} thus ?A ?B by auto
qed
lemma transaction_fresh_subst_has_no_pubconsts_abss:
fixes σ::"('fun,'atom,'sets) prot_subst"
assumes "transaction_fresh_subst σ T 𝒜"
shows "subst_range σ ∩ pubval_terms = {}" (is ?A)
and "subst_range σ ∩ abs_terms = {}" (is ?B)
proof -
{ fix t assume "t ∈ subst_range σ"
then obtain n where "t = Fun (Val (n,False)) []"
using assms unfolding transaction_fresh_subst_def
by force
hence "t ∉ pubval_terms" "t ∉ abs_terms" by simp_all
} thus ?A ?B by auto
qed
lemma reachable_constraints_no_pubconsts_abss:
assumes "𝒜 ∈ reachable_constraints P"
and P: "∀T ∈ set P. ∀n. Val (n,True) ∉ ⋃(funs_term ` trms_transaction T)"
"∀T ∈ set P. ∀n. Abs n ∉ ⋃(funs_term ` trms_transaction T)"
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set P. bvars⇩l⇩s⇩s⇩t (transaction_strand T) = {}"
and ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
"∀n. Val (n,True) ∉ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
"∀n. Abs n ∉ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
shows "trms⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊆ GSMP (⋃T ∈ set P. trms_transaction T) - (pubval_terms ∪ abs_terms)"
(is "?A ⊆ ?B")
using assms(1) ℐ(4,5)
proof (induction 𝒜 rule: reachable_constraints.induct)
case (step 𝒜 T σ α)
define trms_P where "trms_P ≡ (⋃T ∈ set P. trms_transaction T)"
define T' where "T' ≡ transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"
have ℐ': "∀n. Val (n,True) ∉ ⋃ (funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
"∀n. Abs n ∉ ⋃ (funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
using step.prems fv⇩s⇩s⇩t_append[of "unlabel 𝒜"] unlabel_append[of 𝒜]
by auto
have "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using transaction_renaming_subst_wt[OF step.hyps(4)]
transaction_fresh_subst_wt[OF step.hyps(3)]
by (metis step.hyps(2) P(3) wt_subst_compose)
hence "wt⇩s⇩u⇩b⇩s⇩t (rm_vars (set X) (σ ∘⇩s α))" for X
using wt_subst_rm_vars[of "σ ∘⇩s α" "set X"]
by metis
hence wt: "wt⇩s⇩u⇩b⇩s⇩t ((rm_vars (set X) (σ ∘⇩s α)) ∘⇩s ℐ)" for X
using ℐ(2) wt_subst_compose by fast
have "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α))"
using transaction_fresh_subst_range_wf_trms[OF step.hyps(3)]
transaction_renaming_subst_range_wf_trms[OF step.hyps(4)]
by (metis wf_trms_subst_compose)
hence wftrms: "wf⇩t⇩r⇩m⇩s (subst_range ((rm_vars (set X) (σ ∘⇩s α)) ∘⇩s ℐ))" for X
using wf_trms_subst_compose[OF wf_trms_subst_rm_vars' ℐ(3)] by fast
have "trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t T') ⋅⇩s⇩e⇩t ℐ ⊆ ?B"
proof
fix t assume "t ∈ trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t T') ⋅⇩s⇩e⇩t ℐ"
hence "t ∈ trms⇩l⇩s⇩s⇩t T' ⋅⇩s⇩e⇩t ℐ" using trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq by blast
then obtain s X where s:
"s ∈ trms_transaction T"
"t = s ⋅ rm_vars (set X) (σ ∘⇩s α) ∘⇩s ℐ"
"set X ⊆ bvars_transaction T"
using trms⇩s⇩s⇩t_unlabel_subst'' unfolding T'_def by blast
define θ where "θ ≡ rm_vars (set X) (σ ∘⇩s α)"
have 1: "s ∈ trms_P" using step.hyps(2) s(1) unfolding trms_P_def by auto
have s_nin: "s ∉ pubval_terms" "s ∉ abs_terms"
using 1 P(1,2) funs_term_Fun_subterm
unfolding trms_P_def is_Val_def is_Abs_def
by fastforce+
have 2: "(ℐ ` fv⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t T')) ∩ pubval_terms = {}"
"(ℐ ` fv⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t T')) ∩ abs_terms = {}"
"subst_range (σ ∘⇩s α) ∩ pubval_terms = {}"
"subst_range (σ ∘⇩s α) ∩ abs_terms = {}"
"subst_range θ ∩ pubval_terms = {}"
"subst_range θ ∩ abs_terms = {}"
"(θ ` fv s) ∩ pubval_terms = {}"
"(θ ` fv s) ∩ abs_terms = {}"
unfolding T'_def θ_def
using step.prems funs_term_Fun_subterm
apply (fastforce simp add: is_Val_def,
fastforce simp add: is_Abs_def)
using pubval_terms_subst_range_comp[OF
transaction_fresh_subst_has_no_pubconsts_abss(1)[OF step.hyps(3)]
transaction_renaming_subst_has_no_pubconsts_abss(1)[OF step.hyps(4)]]
abs_terms_subst_range_comp[OF
transaction_fresh_subst_has_no_pubconsts_abss(2)[OF step.hyps(3)]
transaction_renaming_subst_has_no_pubconsts_abss(2)[OF step.hyps(4)]]
unfolding is_Val_def is_Abs_def
by force+
have "(ℐ ` fv (s ⋅ θ)) ∩ pubval_terms = {}"
"(ℐ ` fv (s ⋅ θ)) ∩ abs_terms = {}"
proof -
have "θ = σ ∘⇩s α" "bvars_transaction T = {}" "vars⇩l⇩s⇩s⇩t T' = fv⇩l⇩s⇩s⇩t T'"
using s(3) P(4) step.hyps(2) rm_vars_empty
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel T'"]
bvars⇩s⇩s⇩t_subst[of "unlabel (transaction_strand T)" "σ ∘⇩s α"]
unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
unfolding θ_def T'_def by simp_all
hence "fv (s ⋅ θ) ⊆ fv⇩l⇩s⇩s⇩t T'"
using trms⇩s⇩s⇩t_fv_subst_subset[OF s(1), of θ] unlabel_subst[of "transaction_strand T" θ]
unfolding T'_def by auto
moreover have "fv⇩l⇩s⇩s⇩t T' ⊆ fv⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t T')"
using fv⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel (dual⇩l⇩s⇩s⇩t T')"]
unlabel_append[of 𝒜 "dual⇩l⇩s⇩s⇩t T'"]
fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of T']
by simp_all
hence "ℐ ` fv⇩l⇩s⇩s⇩t T' ∩ pubval_terms = {}" "ℐ ` fv⇩l⇩s⇩s⇩t T' ∩ abs_terms = {}"
using 2(1,2) by blast+
ultimately show "(ℐ ` fv (s ⋅ θ)) ∩ pubval_terms = {}" "(ℐ ` fv (s ⋅ θ)) ∩ abs_terms = {}"
by blast+
qed
hence σαℐ_disj: "((θ ∘⇩s ℐ) ` fv s) ∩ pubval_terms = {}"
"((θ ∘⇩s ℐ) ` fv s) ∩ abs_terms = {}"
using pubval_terms_subst_range_comp'[of θ "fv s" ℐ]
abs_terms_subst_range_comp'[of θ "fv s" ℐ]
2(7,8)
by (simp_all add: subst_apply_fv_unfold)
have 3: "t ∉ pubval_terms" "t ∉ abs_terms"
using s(2) s_nin σαℐ_disj
pubval_terms_subst[of s "rm_vars (set X) (σ ∘⇩s α) ∘⇩s ℐ"]
pubval_terms_subst_range_disj[of "rm_vars (set X) (σ ∘⇩s α) ∘⇩s ℐ" s]
abs_terms_subst[of s "rm_vars (set X) (σ ∘⇩s α) ∘⇩s ℐ"]
abs_terms_subst_range_disj[of "rm_vars (set X) (σ ∘⇩s α) ∘⇩s ℐ" s]
unfolding θ_def
by blast+
have "t ∈ SMP trms_P" "fv t = {}"
by (metis s(2) SMP.Substitution[OF SMP.MP[OF 1] wt wftrms, of X],
metis s(2) subst_subst_compose[of s "rm_vars (set X) (σ ∘⇩s α)" ℐ]
interpretation_grounds[OF ℐ(1), of "s ⋅ rm_vars (set X) (σ ∘⇩s α)"])
hence 4: "t ∈ GSMP trms_P" unfolding GSMP_def by simp
show "t ∈ ?B" using 3 4 by (auto simp add: trms_P_def)
qed
thus ?case
using step.IH[OF ℐ'] trms⇩s⇩s⇩t_append[of "unlabel 𝒜"] unlabel_append[of 𝒜]
image_Un[of "λx. x ⋅ ℐ" "trms⇩l⇩s⇩s⇩t 𝒜"]
by (simp add: T'_def)
qed simp
lemma α⇩t⇩i_covers_α⇩0_aux:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
"t = Fun (Val n) [] ∨ t = Var x"
and neq:
"t ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) ≠
t ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ)"
shows "∃y ∈ fv_transaction T - set (transaction_fresh T).
t ⋅ ℐ = (σ ∘⇩s α) y ⋅ ℐ ∧ Γ⇩v y = TAtom Value"
proof -
let ?𝒜' = "𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
let ?ℬ = "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T))"
let ?ℬ' = "?ℬ ⋅⇩s⇩s⇩t σ ∘⇩s α"
let ?ℬ'' = "unlabel (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
have ℐ_interp: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wf: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def,
metis ℐ welltyped_constraint_model_def,
metis ℐ welltyped_constraint_model_def constraint_model_def)
have T_adm: "admissible_transaction T"
using T P(1) by blast
hence T_valid: "wellformed_transaction T"
unfolding admissible_transaction_def by blast
have T_adm_upds: "admissible_transaction_updates T"
by (metis P(1) T admissible_transaction_def)
have T_fresh_vars_value_typed: "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
using T P(1) protocol_transaction_vars_TAtom_typed(3)[of T] P(1) by simp
have wt_σα: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using wt_subst_compose transaction_fresh_subst_wt[OF σ T_fresh_vars_value_typed]
transaction_renaming_subst_wt[OF α]
by blast
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P(1) 𝒜_reach)
hence t_wf: "wf⇩t⇩r⇩m t" using t by auto
have 𝒜_no_val_bvars: "¬TAtom Value ⊑ Γ⇩v x"
when "x ∈ bvars⇩l⇩s⇩s⇩t 𝒜" for x
using P(1) reachable_constraints_no_bvars 𝒜_reach
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"] that
unfolding admissible_transaction_def by fast
have x': "x ∈ vars⇩l⇩s⇩s⇩t 𝒜" when "t = Var x"
using that t by (simp add: var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t)
have "∃f ∈ funs_term (t ⋅ ℐ). is_Val f"
using abs_eq_if_no_Val neq by metis
hence "∃n T. Fun (Val n) T ⊑ t ⋅ ℐ"
using funs_term_Fun_subterm
unfolding is_Val_def by fast
hence "TAtom Value ⊑ Γ (Var x)" when "t = Var x"
using wt_subst_trm''[OF ℐ_wt, of "Var x"] that
subtermeq_imp_subtermtypeeq[of "t ⋅ ℐ"] wf_trm_subst[OF ℐ_wf, of t] t_wf
by fastforce
hence x_val: "Γ⇩v x = TAtom Value" when "t = Var x"
using reachable_constraints_vars_TAtom_typed[OF 𝒜_reach P x'] that
by fastforce
hence x_fv: "x ∈ fv⇩l⇩s⇩s⇩t 𝒜" when "t = Var x" using x'
using reachable_constraints_Value_vars_are_fv[OF 𝒜_reach P x'] that
by blast
then obtain m where m: "t ⋅ ℐ = Fun (Val m) []"
using constraint_model_Value_term_is_Val[
OF 𝒜_reach welltyped_constraint_model_prefix[OF ℐ] P, of x]
t(2) x_val
by force
hence 0: "α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) m ≠ α⇩0 (db⇩s⇩s⇩t (unlabel 𝒜@?ℬ'') ℐ) m"
using neq by (simp add: unlabel_def)
have t_val: "Γ t = TAtom Value" using x_val t by force
obtain u s where s: "t ⋅ ℐ = u ⋅ ℐ" "insert⟨u,s⟩ ∈ set ?ℬ' ∨ delete⟨u,s⟩ ∈ set ?ℬ'"
using to_abs_neq_imp_db_update[OF 0] m
by (metis (no_types, lifting) dual⇩l⇩s⇩s⇩t_subst subst_lsst_unlabel)
then obtain u' s' where s':
"u = u' ⋅ σ ∘⇩s α" "s = s' ⋅ σ ∘⇩s α"
"insert⟨u',s'⟩ ∈ set ?ℬ ∨ delete⟨u',s'⟩ ∈ set ?ℬ"
using stateful_strand_step_subst_inv_cases(4,5)
by blast
hence s'': "insert⟨u',s'⟩ ∈ set (unlabel (transaction_strand T)) ∨
delete⟨u',s'⟩ ∈ set (unlabel (transaction_strand T))"
using dual⇩l⇩s⇩s⇩t_unlabel_steps_iff(4,5)[of u' s' "transaction_strand T"]
by simp_all
then obtain y where y: "y ∈ fv_transaction T" "u' = Var y"
using transaction_inserts_are_Value_vars[OF T_valid T_adm_upds, of u' s']
transaction_deletes_are_Value_vars[OF T_valid T_adm_upds, of u' s']
stateful_strand_step_fv_subset_cases(4,5)[of u' s' "unlabel (transaction_strand T)"]
by auto
hence 1: "t ⋅ ℐ = (σ ∘⇩s α) y ⋅ ℐ" using y s(1) s'(1) by (metis subst_apply_term.simps(1))
have 2: "y ∉ set (transaction_fresh T)" when "(σ ∘⇩s α) y ⋅ ℐ ≠ σ y"
using transaction_fresh_subst_grounds_domain[OF σ, of y] subst_compose[of σ α y] that
by (auto simp add: subst_ground_ident)
have 3: "y ∉ set (transaction_fresh T)" when "(σ ∘⇩s α) y ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
using 2 that σ unfolding transaction_fresh_subst_def by fastforce
have 4: "∀x ∈ fv⇩l⇩s⇩s⇩t 𝒜. Γ⇩v x = TAtom Value ⟶
(∃B. prefix B 𝒜 ∧ x ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B))"
by (metis welltyped_constraint_model_prefix[OF ℐ]
constraint_model_Value_var_in_constr_prefix[OF 𝒜_reach _ P])
have 5: "Γ⇩v y = TAtom Value"
using 1 t_val
wt_subst_trm''[OF wt_σα, of "Var y"]
wt_subst_trm''[OF ℐ_wt, of t]
wt_subst_trm''[OF ℐ_wt, of "(σ ∘⇩s α) y"]
by (auto simp del: subst_subst_compose)
have "y ∉ set (transaction_fresh T)"
proof (cases "t = Var x")
case True
hence *: "ℐ x = Fun (Val m) []" "x ∈ fv⇩l⇩s⇩s⇩t 𝒜" "ℐ x = (σ ∘⇩s α) y ⋅ ℐ"
using m t(1) 1 x_fv x' by (force, blast, force)
obtain B where B: "prefix B 𝒜" "ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using *(2) 4 x_val[OF True] by fastforce
hence "∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using transaction_fresh_subst_range_fresh(1)[OF σ] trms⇩s⇩s⇩t_unlabel_prefix_subset(1)[of B]
unfolding prefix_def by fast
thus ?thesis using *(1,3) B(2) 2 by (metis subst_imgI term.distinct(1))
next
case False
hence "t ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" using t by simp
thus ?thesis using 1 3 by argo
qed
thus ?thesis using 1 5 y(1) by fast
qed
lemma α⇩t⇩i_covers_α⇩0_Var:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "x ∈ fv⇩l⇩s⇩s⇩t 𝒜"
shows "ℐ x ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ) ∈
timpl_closure_set {ℐ x ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)} (α⇩t⇩i 𝒜 T σ α ℐ)"
proof -
define a0 where "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
define a0' where "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ)"
define a3 where "a3 ≡ α⇩t⇩i 𝒜 T σ α ℐ"
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P(1) 𝒜_reach)
have T_adm: "admissible_transaction T" by (metis P(1) T)
have ℐ_interp: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def,
metis ℐ welltyped_constraint_model_def,
metis ℐ welltyped_constraint_model_def constraint_model_def)
have "Γ⇩v x = Var Value ∨ (∃a. Γ⇩v x = Var (prot_atom.Atom a))"
using reachable_constraints_vars_TAtom_typed[OF 𝒜_reach P, of x]
x vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"]
by auto
hence "ℐ x ⋅⇩α a0' ∈ timpl_closure_set {ℐ x ⋅⇩α a0} a3"
proof
assume x_val: "Γ⇩v x = TAtom Value"
show "ℐ x ⋅⇩α a0' ∈ timpl_closure_set {ℐ x ⋅⇩α a0} a3"
proof (cases "ℐ x ⋅⇩α a0 = ℐ x ⋅⇩α a0'")
case False
hence "∃y ∈ fv_transaction T - set (transaction_fresh T).
ℐ x = (σ ∘⇩s α) y ⋅ ℐ ∧ Γ⇩v y = TAtom Value"
using α⇩t⇩i_covers_α⇩0_aux[OF 𝒜_reach T ℐ σ α P fv⇩s⇩s⇩t_is_subterm_trms⇩s⇩s⇩t[OF x], of _ x]
unfolding a0_def a0'_def
by fastforce
then obtain y where y:
"y ∈ fv_transaction T - set (transaction_fresh T)"
"ℐ x = (σ ∘⇩s α) y ⋅ ℐ"
"ℐ x ⋅⇩α a0 = (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α a0"
"ℐ x ⋅⇩α a0' = (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α a0'"
"Γ⇩v y = TAtom Value"
by metis
then obtain n where n: "(σ ∘⇩s α) y ⋅ ℐ = Fun (Val (n,False)) []"
using Γ⇩v_TAtom''(2)[of y] x x_val
transaction_var_becomes_Val[
OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ σ α P T, of y]
by force
have "a0 (n,False) ≠ a0' (n,False)"
"y ∈ fv_transaction T"
"y ∉ set (transaction_fresh T)"
"absc (a0 (n,False)) = (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α a0"
"absc (a0' (n,False)) = (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α a0'"
using y n False by force+
hence 1: "(a0 (n,False), a0' (n,False)) ∈ a3"
unfolding a0_def a0'_def a3_def abs_term_implications_def
by blast
have 2: "ℐ x ⋅⇩α a0' ∈ set ⟨a0 (n,False) --» a0' (n,False)⟩⟨ℐ x ⋅⇩α a0⟩"
using y n timpl_apply_const by auto
show ?thesis
using timpl_closure.TI[OF timpl_closure.FP 1] 2
term_variants_pred_iff_in_term_variants[
of "(λ_. [])(Abs (a0 (n, False)) := [Abs (a0' (n, False))])"]
unfolding timpl_closure_set_def timpl_apply_term_def
by auto
qed (auto intro: timpl_closure_setI)
next
assume "∃a. Γ⇩v x = TAtom (Atom a)"
then obtain a where x_atom: "Γ⇩v x = TAtom (Atom a)" by moura
obtain f T where fT: "ℐ x = Fun f T"
using interpretation_grounds[OF ℐ_interp, of "Var x"]
by (cases "ℐ x") auto
have fT_atom: "Γ (Fun f T) = TAtom (Atom a)"
using wt_subst_trm''[OF ℐ_wt, of "Var x"] x_atom fT
by simp
have T: "T = []"
using fT wf_trm_subst[OF ℐ_wf⇩t⇩r⇩m⇩s, of "Var x"] const_type_inv_wf[OF fT_atom]
by fastforce
have f: "¬is_Val f" using fT_atom unfolding is_Val_def by auto
have "ℐ x ⋅⇩α b = ℐ x" for b
using T fT abs_term_apply_const(2)[OF f]
by auto
thus "ℐ x ⋅⇩α a0' ∈ timpl_closure_set {ℐ x ⋅⇩α a0} a3"
by (auto intro: timpl_closure_setI)
qed
thus ?thesis by (metis a0_def a0'_def a3_def)
qed
lemma α⇩t⇩i_covers_α⇩0_Val:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and n: "Fun (Val n) [] ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
shows "Fun (Val n) [] ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ) ∈
timpl_closure_set {Fun (Val n) [] ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)} (α⇩t⇩i 𝒜 T σ α ℐ)"
proof -
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
define a0 where "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
define a0' where "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@T') ℐ)"
define a3 where "a3 ≡ α⇩t⇩i 𝒜 T σ α ℐ"
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P(1) 𝒜_reach)
have T_adm: "admissible_transaction T" by (metis P(1) T)
have "Fun (Abs (a0' n)) [] ∈ timpl_closure_set {Fun (Abs (a0 n)) []} a3"
proof (cases "a0 n = a0' n")
case False
then obtain x where x:
"x ∈ fv_transaction T - set (transaction_fresh T)" "Fun (Val n) [] = (σ ∘⇩s α) x ⋅ ℐ"
using α⇩t⇩i_covers_α⇩0_aux[OF 𝒜_reach T ℐ σ α P n]
by (fastforce simp add: a0_def a0'_def T'_def)
hence "absc (a0 n) = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0" "absc (a0' n) = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0'" by simp_all
hence 1: "(a0 n, a0' n) ∈ a3"
using False x(1)
unfolding a0_def a0'_def a3_def abs_term_implications_def T'_def
by blast
show ?thesis
using timpl_apply_Abs[of "[]" "[]" "a0 n" "a0' n"]
timpl_closure.TI[OF timpl_closure.FP[of "Fun (Abs (a0 n)) []" a3] 1]
term_variants_pred_iff_in_term_variants[of "(λ_. [])(Abs (a0 n) := [Abs (a0' n)])"]
unfolding timpl_closure_set_def timpl_apply_term_def
by force
qed (auto intro: timpl_closure_setI)
thus ?thesis by (simp add: a0_def a0'_def a3_def T'_def)
qed
lemma α⇩t⇩i_covers_α⇩0_ik:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and t: "t ∈ ik⇩l⇩s⇩s⇩t 𝒜"
shows "t ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ) ∈
timpl_closure_set {t ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)} (α⇩t⇩i 𝒜 T σ α ℐ)"
proof -
define a0 where "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
define a0' where "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ)"
define a3 where "a3 ≡ α⇩t⇩i 𝒜 T σ α ℐ"
let ?U = "λT a. map (λs. s ⋅ ℐ ⋅⇩α a) T"
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P(1) 𝒜_reach)
have T_adm: "admissible_transaction T" by (metis P(1) T)
have "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)" "wf⇩t⇩r⇩m t" using 𝒜_wf⇩t⇩r⇩m⇩s t ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset by force+
hence "∀t0 ∈ subterms t. t0 ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set {t0 ⋅ ℐ ⋅⇩α a0} a3"
proof (induction t)
case (Var x) thus ?case
using α⇩t⇩i_covers_α⇩0_Var[OF 𝒜_reach T ℐ σ α P, of x]
ik⇩s⇩s⇩t_var_is_fv[of x "unlabel 𝒜"] vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"]
by (simp add: a0_def a0'_def a3_def)
next
case (Fun f S)
have IH: "∀t0 ∈ subterms t. t0 ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set {t0 ⋅ ℐ ⋅⇩α a0} a3"
when "t ∈ set S" for t
using that Fun.prems(1) wf_trm_param[OF Fun.prems(2)] Fun.IH
by (meson in_subterms_subset_Union params_subterms subsetCE)
hence "t ⋅⇩α a0' ∈ timpl_closure_set {t ⋅⇩α a0} a3"
when "t ∈ set (map (λs. s ⋅ ℐ) S)" for t
using that by auto
hence "t ⋅⇩α a0' ∈ timpl_closure (t ⋅⇩α a0) a3"
when "t ∈ set (map (λs. s ⋅ ℐ) S)" for t
using that timpl_closureton_is_timpl_closure by auto
hence "(t ⋅⇩α a0, t ⋅⇩α a0') ∈ timpl_closure' a3"
when "t ∈ set (map (λs. s ⋅ ℐ) S)" for t
using that timpl_closure_is_timpl_closure' by auto
hence IH': "((?U S a0) ! i, (?U S a0') ! i) ∈ timpl_closure' a3"
when "i < length (map (λs. s ⋅ ℐ ⋅⇩α a0) S)" for i
using that by auto
show ?case
proof (cases "∃n. f = Val n")
case True
then obtain n where "Fun f S = Fun (Val n) []"
using Fun.prems(2) unfolding wf⇩t⇩r⇩m_def by force
moreover have "Fun f S ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
using ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset Fun.prems(1) by blast
ultimately show ?thesis
using α⇩t⇩i_covers_α⇩0_Val[OF 𝒜_reach T ℐ σ α P]
by (simp add: a0_def a0'_def a3_def)
next
case False
hence "Fun f S ⋅ ℐ ⋅⇩α a = Fun f (map (λt. t ⋅ ℐ ⋅⇩α a) S)" for a by (cases f) simp_all
hence "(Fun f S ⋅ ℐ ⋅⇩α a0, Fun f S ⋅ ℐ ⋅⇩α a0') ∈ timpl_closure' a3"
using timpl_closure_FunI[OF IH']
by simp
hence "Fun f S ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set {Fun f S ⋅ ℐ ⋅⇩α a0} a3"
using timpl_closureton_is_timpl_closure
timpl_closure_is_timpl_closure'
by metis
thus ?thesis using IH by simp
qed
qed
thus ?thesis by (simp add: a0_def a0'_def a3_def)
qed
lemma transaction_prop1:
assumes "δ ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
and "x ∈ fv_transaction T"
and "x ∉ set (transaction_fresh T)"
and "δ x ≠ absdbupd (unlabel (transaction_updates T)) x (δ x)"
and "transaction_check FP OCC TI T"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
shows "(δ x, absdbupd (unlabel (transaction_updates T)) x (δ x)) ∈ (set TI)⇧+"
proof -
let ?upd = "λx. absdbupd (unlabel (transaction_updates T)) x (δ x)"
have 0: "fv_transaction T = set (fv_list⇩s⇩s⇩t (unlabel (transaction_strand T)))"
by (metis fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t[of "unlabel (transaction_strand T)"])
have 1: "transaction_check_post FP TI T δ"
using assms(1,5)
unfolding transaction_check_def list_all_iff
by blast
have "(δ x, ?upd x) ∈ set TI ⟷ (δ x, ?upd x) ∈ (set TI)⇧+"
using TI using assms(4) by blast
thus ?thesis
using assms(2,3,4) 0 1 in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
unfolding transaction_check_post_def List.member_def
by (metis (no_types, lifting) DiffI)
qed
lemma transaction_prop2:
assumes δ: "δ ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
and x: "x ∈ fv_transaction T" "fst x = TAtom Value"
and T_check: "transaction_check FP OCC TI T"
and T_adm: "admissible_transaction T"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
shows "x ∉ set (transaction_fresh T) ⟹ δ x ∈ set OCC" (is "?A' ⟹ ?A")
and "absdbupd (unlabel (transaction_updates T)) x (δ x) ∈ set OCC" (is ?B)
proof -
let ?xs = "fv_list⇩s⇩s⇩t (unlabel (transaction_strand T))"
let ?ys = "filter (λx. x ∉ set (transaction_fresh T) ∧ fst x = TAtom Value) ?xs"
let ?C = "unlabel (transaction_selects T@transaction_checks T)"
let ?poss = "transaction_poschecks_comp ?C"
let ?negs = "transaction_negchecks_comp ?C"
let ?δupd = "λy. absdbupd (unlabel (transaction_updates T)) y (δ y)"
have T_wf: "wellformed_transaction T"
and T_occ: "admissible_transaction_occurs_checks T"
using T_adm by (metis admissible_transaction_def)+
have 0: "{x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value} = set ?ys"
using fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t[of "unlabel (transaction_strand T)"]
by force
have 1: "transaction_check_pre FP TI T δ"
using δ unfolding transaction_check_comp_def Let_def by fastforce
have 2: "transaction_check_post FP TI T δ"
using δ T_check unfolding transaction_check_def list_all_iff by blast
have 3: "δ ∈ abs_substs_fun ` set (abs_substs_set ?ys OCC ?poss ?negs)"
using δ unfolding transaction_check_comp_def Let_def by force
show A: ?A when ?A' using that 0 3 x abs_substs_abss_bounded by blast
have 4: "x ∈ fv⇩l⇩s⇩s⇩t (transaction_updates T) ∪ fv⇩l⇩s⇩s⇩t (transaction_send T)"
when x': "x ∈ set (transaction_fresh T)"
using T_wf x' unfolding wellformed_transaction_def by fast
have "intruder_synth_mod_timpls FP TI (occurs (absc (?δupd x)))"
when x': "x ∈ set (transaction_fresh T)"
using 2 x' x T_occ
unfolding transaction_check_post_def admissible_transaction_occurs_checks_def
by fastforce
hence "timpl_closure_set (set FP) (set TI) ⊢⇩c occurs (absc (?δupd x))"
when x': "x ∈ set (transaction_fresh T)"
using x' intruder_synth_mod_timpls_is_synth_timpl_closure_set[
OF TI, of FP "occurs (absc (?δupd x))"]
by argo
hence "Abs (?δupd x) ∈ ⋃(funs_term ` timpl_closure_set (set FP) (set TI))"
when x': "x ∈ set (transaction_fresh T)"
using x' ideduct_synth_priv_fun_in_ik[
of "timpl_closure_set (set FP) (set TI)" "occurs (absc (?δupd x))"]
by simp
hence "∃t ∈ timpl_closure_set (set FP) (set TI). Abs (?δupd x) ∈ funs_term t"
when x': "x ∈ set (transaction_fresh T)"
using x' by force
hence 5: "?δupd x ∈ set OCC" when x': "x ∈ set (transaction_fresh T)"
using x' OCC by fastforce
have 6: "?δupd x ∈ set OCC" when x': "x ∉ set (transaction_fresh T)"
proof (cases "δ x = ?δupd x")
case False
hence "(δ x, ?δupd x) ∈ (set TI)⇧+" "δ x ∈ set OCC"
using A 2 x' x TI
unfolding transaction_check_post_def fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t Let_def
in_trancl_closure_iff_in_trancl_fun[symmetric]
List.member_def
by blast+
thus ?thesis using timpl_closure_set_absc_subset_in[OF OCC(2)] by blast
qed (simp add: A x' x(1))
show ?B by (metis 5 6)
qed
lemma transaction_prop3:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
shows "∀x ∈ set (transaction_fresh T). (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc {}" (is ?A)
and "∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T).
intruder_synth_mod_timpls FP TI (t ⋅ (σ ∘⇩s α) ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ))" (is ?B)
and "∀x ∈ fv_transaction T - set (transaction_fresh T).
∀s. select⟨Var x,Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))
⟶ (∃ss. (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∈ ss)" (is ?C)
and "∀x ∈ fv_transaction T - set (transaction_fresh T).
∀s. ⟨Var x in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))
⟶ (∃ss. (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∈ ss)" (is ?D)
and "∀x ∈ fv_transaction T - set (transaction_fresh T).
∀s. ⟨Var x not in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))
⟶ (∃ss. (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∉ ss)" (is ?E)
and "∀x ∈ fv_transaction T - set (transaction_fresh T). Γ⇩v x = TAtom Value ⟶
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) ∈ absc ` set OCC" (is ?F)
proof -
let ?T' = "dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
define a0 where "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
define a0' where "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@?T') ℐ)"
define fv_AT' where "fv_AT' ≡ fv⇩l⇩s⇩s⇩t (𝒜@?T')"
have T_adm: "admissible_transaction T"
using T P(1) by blast
hence T_valid: "wellformed_transaction T"
unfolding admissible_transaction_def by blast
have T_adm':
"admissible_transaction_selects T"
"admissible_transaction_checks T"
"admissible_transaction_updates T"
using T_adm unfolding admissible_transaction_def by simp_all
have ℐ': "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
"∀n. Val (n,True) ∉ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
"∀n. Abs n ∉ ⋃(funs_term ` (ℐ ` fv⇩l⇩s⇩s⇩t 𝒜))"
"∀n. Val (n,True) ∉ ⋃(funs_term ` (ℐ ` fv_AT'))"
"∀n. Abs n ∉ ⋃(funs_term ` (ℐ ` fv_AT'))"
using ℐ admissible_transaction_occurs_checks_prop'[
OF 𝒜_reach welltyped_constraint_model_prefix[OF ℐ] P]
admissible_transaction_occurs_checks_prop'[
OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ P]
unfolding welltyped_constraint_model_def constraint_model_def is_Val_def is_Abs_def fv_AT'_def
by fastforce+
have 𝒫': "∀T ∈ set P. ∀n. Val (n,True) ∉ ⋃(funs_term ` trms_transaction T)"
"∀T ∈ set P. ∀n. Abs n ∉ ⋃(funs_term ` trms_transaction T)"
"∀T ∈ set P. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
and "∀T ∈ set P. ∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
using protocol_transaction_vars_TAtom_typed
protocol_transactions_no_pubconsts
protocol_transactions_no_abss
funs_term_Fun_subterm P
by fast+
hence T_no_pubconsts: "∀n. Val (n,True) ∉ ⋃(funs_term ` trms_transaction T)"
and T_no_abss: "∀n. Abs n ∉ ⋃(funs_term ` trms_transaction T)"
and T_fresh_vars_value_typed: "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
and T_fv_const_typed: "∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
using T by simp_all
have wt_σαℐ: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α ∘⇩s ℐ)"
using ℐ'(2) wt_subst_compose transaction_fresh_subst_wt[OF σ T_fresh_vars_value_typed]
transaction_renaming_subst_wt[OF α]
by blast
have 1: "(σ ∘⇩s α) y ⋅ ℐ = σ y" when "y ∈ set (transaction_fresh T)" for y
using transaction_fresh_subst_grounds_domain[OF σ that] subst_compose[of σ α y]
by (simp add: subst_ground_ident)
have 2: "(σ ∘⇩s α) y ⋅ ℐ ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" when "y ∈ set (transaction_fresh T)" for y
using 1[OF that] that σ unfolding transaction_fresh_subst_def by auto
have 3: "∀x ∈ fv⇩l⇩s⇩s⇩t 𝒜. Γ⇩v x = TAtom Value ⟶
(∃B. prefix B 𝒜 ∧ x ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B))"
by (metis welltyped_constraint_model_prefix[OF ℐ]
constraint_model_Value_var_in_constr_prefix[OF 𝒜_reach _ P])
have 4: "∃n. (σ ∘⇩s α) y ⋅ ℐ = Fun (Val n) []"
when "y ∈ fv_transaction T" "Γ⇩v y = TAtom Value" for y
using transaction_var_becomes_Val[OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ σ α P T]
that T_fv_const_typed Γ⇩v_TAtom''[of y]
by metis
have ℐ_is_T_model: "strand_sem_stateful (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) (set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)) (unlabel ?T') ℐ"
using ℐ unlabel_append[of 𝒜 ?T'] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of "unlabel 𝒜" ℐ "[]"]
strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "unlabel ?T'" ℐ]
by (simp add: welltyped_constraint_model_def constraint_model_def db⇩s⇩s⇩t_def)
have T_rcv_no_val_bvars: "bvars⇩l⇩s⇩s⇩t (transaction_receive T) ∩ subst_domain (σ ∘⇩s α) = {}"
using transaction_no_bvars[OF T_adm] bvars_transaction_unfold[of T] by blast
show ?A
proof
fix y assume y: "y ∈ set (transaction_fresh T)"
then obtain yn where yn: "(σ ∘⇩s α) y ⋅ ℐ = Fun (Val yn) []" "Fun (Val yn) [] ∈ subst_range σ"
by (metis transaction_fresh_subst_sends_to_val'[OF σ])
{
fix t' s assume t': "insert⟨t',s⟩ ∈ set (unlabel 𝒜)" "t' ⋅ ℐ = Fun (Val yn) []"
then obtain z where t'_z: "t' = Var z" using 2[OF y] yn(1) by (cases t') auto
hence z: "z ∈ fv⇩l⇩s⇩s⇩t 𝒜" "ℐ z = (σ ∘⇩s α) y ⋅ ℐ" using t' yn(1) by force+
hence z': "Γ⇩v z = TAtom Value"
by (metis Γ.simps(1) Γ_consts_simps(2) t'(2) t'_z wt_subst_trm'' ℐ'(2))
obtain B where B: "prefix B 𝒜" "ℐ z ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)" using z z' 3 by fastforce
hence "∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using transaction_fresh_subst_range_fresh(1)[OF σ] trms⇩s⇩s⇩t_unlabel_prefix_subset(1)[of B]
unfolding prefix_def by fast
hence False using B(2) 1[OF y] z yn(1) by (metis subst_imgI term.distinct(1))
} hence "∄s. ((σ ∘⇩s α) y ⋅ ℐ, s) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using db⇩s⇩s⇩t_in_cases[of "(σ ∘⇩s α) y ⋅ ℐ" _ "unlabel 𝒜" ℐ "[]"] yn(1)
by (force simp add: db⇩s⇩s⇩t_def)
thus "(σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc {}"
using to_abs_empty_iff_notin_db[of yn "db'⇩l⇩s⇩s⇩t 𝒜 ℐ []"] yn(1)
by (simp add: db⇩s⇩s⇩t_def)
qed
show receives_covered: ?B
proof
fix t assume t: "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T)"
hence t_in_T: "t ∈ trms_transaction T"
using trms⇩s⇩s⇩t_unlabel_prefix_subset(1)[of "transaction_receive T"]
unfolding transaction_strand_def by fast
have t_rcv: "receive⟨t ⋅ σ ∘⇩s α⟩ ∈ set (unlabel (transaction_receive T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using subst_lsst_unlabel_member[of "receive⟨t⟩" "transaction_receive T" "σ ∘⇩s α"]
wellformed_transaction_unlabel_cases(1)[OF T_valid] trms⇩s⇩s⇩t_in[OF t]
by fastforce
hence *: "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ σ ∘⇩s α ⋅ ℐ"
using wellformed_transaction_sem_receives[OF T_valid ℐ_is_T_model]
by simp
have t_fv: "fv (t ⋅ σ ∘⇩s α) ⊆ fv_AT'"
using fv⇩s⇩s⇩t_append[of "unlabel 𝒜"] unlabel_append[of 𝒜]
fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
t_rcv fv_transaction_subst_unfold[of T " σ ∘⇩s α"]
unfolding fv_AT'_def by force
have **: "∀t ∈ (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
using FP(3) by (auto simp add: a0_def abs_intruder_knowledge_def)
note lms1 = pubval_terms_subst[OF _ pubval_terms_subst_range_disj[
OF transaction_fresh_subst_has_no_pubconsts_abss(1)[OF σ], of t]]
pubval_terms_subst[OF _ pubval_terms_subst_range_disj[
OF transaction_renaming_subst_has_no_pubconsts_abss(1)[OF α], of "t ⋅ σ"]]
note lms2 = abs_terms_subst[OF _ abs_terms_subst_range_disj[
OF transaction_fresh_subst_has_no_pubconsts_abss(2)[OF σ], of t]]
abs_terms_subst[OF _ abs_terms_subst_range_disj[
OF transaction_renaming_subst_has_no_pubconsts_abss(2)[OF α], of "t ⋅ σ"]]
have "t ∈ (⋃T∈set P. trms_transaction T)" "fv (t ⋅ σ ∘⇩s α ⋅ ℐ) = {}"
using t_in_T T interpretation_grounds[OF ℐ'(1)] by fast+
moreover have "wf⇩t⇩r⇩m⇩s (subst_range (σ ∘⇩s α ∘⇩s ℐ))"
using wf_trm_subst_rangeI[of σ, OF transaction_fresh_subst_is_wf_trm[OF σ]]
wf_trm_subst_rangeI[of α, OF transaction_renaming_subst_is_wf_trm[OF α]]
wf_trms_subst_compose[of σ α, THEN wf_trms_subst_compose[OF _ ℐ'(3)]]
by blast
moreover
have "t ∉ pubval_terms"
using t_in_T T_no_pubconsts funs_term_Fun_subterm
unfolding is_Val_def by fastforce
hence "t ⋅ σ ∘⇩s α ∉ pubval_terms"
using lms1
by auto
hence "t ⋅ σ ∘⇩s α ⋅ ℐ ∉ pubval_terms"
using ℐ'(6) t_fv pubval_terms_subst'[of "t ⋅ σ ∘⇩s α" ℐ]
by auto
moreover have "t ∉ abs_terms"
using t_in_T T_no_abss funs_term_Fun_subterm
unfolding is_Abs_def by force
hence "t ⋅ σ ∘⇩s α ∉ abs_terms"
using lms2
by auto
hence "t ⋅ σ ∘⇩s α ⋅ ℐ ∉ abs_terms"
using ℐ'(7) t_fv abs_terms_subst'[of "t ⋅ σ ∘⇩s α" ℐ]
by auto
ultimately have ***:
"t ⋅ σ ∘⇩s α ⋅ ℐ ∈ GSMP (⋃T∈set P. trms_transaction T) - (pubval_terms ∪ abs_terms)"
using SMP.Substitution[OF SMP.MP[of t "⋃T∈set P. trms_transaction T"], of "σ ∘⇩s α ∘⇩s ℐ"]
subst_subst_compose[of t "σ ∘⇩s α" ℐ] wt_σαℐ
unfolding GSMP_def by fastforce
have "∀T∈set P. bvars_transaction T = {}"
using transaction_no_bvars P unfolding list_all_iff by blast
hence ****:
"ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊆ GSMP (⋃T∈set P. trms_transaction T) - (pubval_terms ∪ abs_terms)"
using reachable_constraints_no_pubconsts_abss[OF 𝒜_reach 𝒫' _ ℐ'(1,2,3,4,5)]
ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset[of "unlabel 𝒜"]
by blast
show "intruder_synth_mod_timpls FP TI (t ⋅ σ ∘⇩s α ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ))"
using deduct_FP_if_deduct[OF **** ** * ***] deducts_eq_if_analyzed[OF FP(1)]
intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, of FP]
unfolding a0_def by force
qed
show ?C
proof (intro ballI allI impI)
fix y s
assume y: "y ∈ fv_transaction T - set (transaction_fresh T)"
and s: "select⟨Var y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))"
hence "select⟨Var y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_strand T))"
unfolding transaction_strand_def unlabel_def by auto
hence y_val: "Γ⇩v y = TAtom Value"
using transaction_selects_are_Value_vars[OF T_valid T_adm'(1)]
by fastforce
have "select⟨(σ ∘⇩s α) y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T ⋅⇩l⇩s⇩s⇩t (σ ∘⇩s α)))"
using subst_lsst_unlabel_member[OF s]
by fastforce
hence "((σ ∘⇩s α) y ⋅ ℐ, Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using wellformed_transaction_sem_selects[
OF T_valid ℐ_is_T_model,
of "(σ ∘⇩s α) y" "Fun (Set s) []"]
by simp
thus "∃ss. (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∈ ss"
using to_abs_alt_def[of "db⇩l⇩s⇩s⇩t 𝒜 ℐ"] 4[of y] y y_val by auto
qed
show ?D
proof (intro ballI allI impI)
fix y s
assume y: "y ∈ fv_transaction T - set (transaction_fresh T)"
and s: "⟨Var y in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))"
hence "⟨Var y in Fun (Set s) []⟩ ∈ set (unlabel (transaction_strand T))"
unfolding transaction_strand_def unlabel_def by auto
hence y_val: "Γ⇩v y = TAtom Value"
using transaction_inset_checks_are_Value_vars[OF T_valid T_adm'(2)]
by fastforce
have "⟨(σ ∘⇩s α) y in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T ⋅⇩l⇩s⇩s⇩t (σ ∘⇩s α)))"
using subst_lsst_unlabel_member[OF s]
by fastforce
hence "((σ ∘⇩s α) y ⋅ ℐ, Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using wellformed_transaction_sem_pos_checks[
OF T_valid ℐ_is_T_model,
of "(σ ∘⇩s α) y" "Fun (Set s) []"]
by simp
thus "∃ss. (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∈ ss"
using to_abs_alt_def[of "db⇩l⇩s⇩s⇩t 𝒜 ℐ"] 4[of y] y y_val by auto
qed
show ?E
proof (intro ballI allI impI)
fix y s
assume y: "y ∈ fv_transaction T - set (transaction_fresh T)"
and s: "⟨Var y not in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T))"
hence "⟨Var y not in Fun (Set s) []⟩ ∈ set (unlabel (transaction_strand T))"
unfolding transaction_strand_def unlabel_def by auto
hence y_val: "Γ⇩v y = TAtom Value"
using transaction_notinset_checks_are_Value_vars[OF T_valid T_adm'(2)]
by fastforce
have "⟨(σ ∘⇩s α) y not in Fun (Set s) []⟩ ∈ set (unlabel (transaction_checks T ⋅⇩l⇩s⇩s⇩t (σ ∘⇩s α)))"
using subst_lsst_unlabel_member[OF s]
by fastforce
hence "((σ ∘⇩s α) y ⋅ ℐ, Fun (Set s) []) ∉ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using wellformed_transaction_sem_neg_checks(2)[
OF T_valid ℐ_is_T_model,
of "[]" "(σ ∘⇩s α) y" "Fun (Set s) []"]
by simp
moreover have "list_all admissible_transaction_updates P"
using Ball_set[of P "admissible_transaction"] P(1)
Ball_set[of P admissible_transaction_updates]
unfolding admissible_transaction_def
by fast
moreover have "list_all wellformed_transaction P"
using P(1) Ball_set[of P "admissible_transaction"] Ball_set[of P wellformed_transaction]
unfolding admissible_transaction_def
by blast
ultimately have "((σ ∘⇩s α) y ⋅ ℐ, Fun (Set s) S) ∉ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)" for S
using reachable_constraints_db⇩l⇩s⇩s⇩t_set_args_empty[OF 𝒜_reach]
unfolding admissible_transaction_updates_def
by auto
thus "∃ss. (σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = absc ss ∧ s ∉ ss"
using to_abs_alt_def[of "db⇩l⇩s⇩s⇩t 𝒜 ℐ"] 4[of y] y y_val by auto
qed
show ?F
proof (intro ballI impI)
fix y assume y: "y ∈ fv_transaction T - set (transaction_fresh T)" "Γ⇩v y = TAtom Value"
then obtain yn where yn: "(σ ∘⇩s α) y ⋅ ℐ = Fun (Val yn) []" using 4 by moura
hence y_abs: "(σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) = Fun (Abs (α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) yn)) []" by simp
have *: "∀r ∈ set (unlabel (transaction_selects T)). ∃x s. r = select⟨Var x, Fun (Set s) []⟩"
using admissible_transaction_strand_step_cases(2)[OF T_adm] by fast
have "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∨ y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using wellformed_transaction_fv_in_receives_or_selects[OF T_valid] y by blast
thus "(σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) ∈ absc ` set OCC"
proof
assume "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T)"
then obtain t where t: "receive⟨t⟩ ∈ set (unlabel (transaction_receive T))" "y ∈ fv t"
using wellformed_transaction_unlabel_cases(1)[OF T_valid]
by (force simp add: unlabel_def)
have **: "(σ ∘⇩s α) y ⋅ ℐ ∈ subterms (t ⋅ σ ∘⇩s α ∘⇩s ℐ)"
"timpl_closure_set (set FP) (set TI) ⊢⇩c t ⋅ σ ∘⇩s α ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using fv_subterms_substI[OF t(2), of "σ ∘⇩s α ∘⇩s ℐ"] subst_compose[of "σ ∘⇩s α" ℐ y]
subterms_subst_subset[of "σ ∘⇩s α ∘⇩s ℐ" t] receives_covered t(1)
unfolding intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, symmetric]
by auto
have "Abs (α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) yn) ∈ ⋃(funs_term ` (timpl_closure_set (set FP) (set TI)))"
using y_abs abs_subterms_in[OF **(1), of "α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"]
ideduct_synth_priv_fun_in_ik[
OF **(2) funs_term_Fun_subterm'[of "Abs (α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) yn)" "[]"]]
by force
hence "(σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) ∈ subterms⇩s⇩e⇩t (timpl_closure_set (set FP) (set TI))"
using y_abs wf_trms_subterms[OF timpl_closure_set_wf_trms[OF FP(2), of "set TI"]]
funs_term_Fun_subterm[of "Abs (α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ) yn)"]
unfolding wf⇩t⇩r⇩m_def by fastforce
hence "funs_term ((σ ∘⇩s α) y ⋅ ℐ ⋅⇩α α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ))
⊆ (⋃t ∈ timpl_closure_set (set FP) (set TI). funs_term t)"
using funs_term_subterms_eq(2)[of "timpl_closure_set (set FP) (set TI)"] by blast
thus ?thesis using y_abs OCC(1) by fastforce
next
assume "y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
then obtain l s where "(l,select⟨Var y, Fun (Set s) []⟩) ∈ set (transaction_selects T)"
using * by (auto simp add: unlabel_def)
then obtain U where U:
"prefix (U@[(l,select⟨Var y, Fun (Set s) []⟩)]) (transaction_selects T)"
using in_set_conv_decomp[of "(l, select⟨Var y,Fun (Set s) []⟩)" "transaction_selects T"]
by (auto simp add: prefix_def)
hence "select⟨Var y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))"
by (force simp add: prefix_def unlabel_def)
hence "select⟨(σ ∘⇩s α) y, Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using subst_lsst_unlabel_member
by fastforce
hence "(Fun (Val yn) [], Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using yn wellformed_transaction_sem_selects[
OF T_valid ℐ_is_T_model, of "(σ ∘⇩s α) y" "Fun (Set s) []"]
by fastforce
hence "Fun (Val yn) [] ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜) ⋅⇩s⇩e⇩t ℐ"
using db⇩s⇩s⇩t_in_cases[of "Fun (Val yn) []"]
by (fastforce simp add: db⇩s⇩s⇩t_def)
thus ?thesis
using OCC(3) yn abs_in[of "Fun (Val yn) []" _ "α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"]
unfolding abs_value_constants_def
by (metis (mono_tags, lifting) mem_Collect_eq subsetCE)
qed
qed
qed
lemma transaction_prop4:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and P: "∀T ∈ set P. admissible_transaction T"
and x: "x ∈ set (transaction_fresh T)"
and y: "y ∈ fv_transaction T - set (transaction_fresh T)" "Γ⇩v y = TAtom Value"
shows "(σ ∘⇩s α) x ⋅ ℐ ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))" (is ?A)
and "(σ ∘⇩s α) y ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))" (is ?B)
proof -
let ?T' = "dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
from ℐ have ℐ': "welltyped_constraint_model ℐ 𝒜"
using welltyped_constraint_model_prefix by auto
have T_P_addm: "admissible_transaction T'" when T': "T' ∈ set P " for T'
by (meson T' P)
have T_adm: "admissible_transaction T"
by (metis (full_types) P T)
from T_adm have T_valid: "wellformed_transaction T"
unfolding admissible_transaction_def by blast
have be: "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using T_P_addm 𝒜_reach reachable_constraints_no_bvars transaction_no_bvars(2) by blast
have T_no_bvars: "fv_transaction T = vars_transaction T"
using transaction_no_bvars[OF T_adm] by simp
have ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ" by (metis ℐ welltyped_constraint_model_def)
obtain xn where xn: "σ x = Fun (Val xn) []"
using σ x unfolding transaction_fresh_subst_def by force
then have xnxn: "(σ ∘⇩s α) x = Fun (Val xn) []"
unfolding subst_compose_def by auto
from xn xnxn have a0: "(σ ∘⇩s α) x ⋅ ℐ = Fun (Val xn) []"
by auto
have b0: "Γ⇩v x = TAtom Value"
using P x T protocol_transaction_vars_TAtom_typed(3)
by metis
note 0 = a0 b0
have xT: "x ∈ fv_transaction T"
using x transaction_fresh_vars_subset[OF T_valid]
by fast
have σ_x_nin_A: "σ x ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
proof -
have "σ x ∈ subst_range σ"
by (metis σ transaction_fresh_subst_sends_to_val x)
moreover
have "(∀t ∈ subst_range σ. t ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜))"
using σ transaction_fresh_subst_def[of σ T 𝒜] by auto
ultimately
show ?thesis
by auto
qed
have *: "y ∉ set (transaction_fresh T)"
using assms by auto
have **: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T) ∨ y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
using * y wellformed_transaction_fv_in_receives_or_selects[OF T_valid]
by blast
have y_fv: "y ∈ fv_transaction T" using y fv_transaction_unfold by blast
have y_val: "fst y = TAtom Value" using y(2) Γ⇩v_TAtom''(2) by blast
have "list_all (λx. fst x = Var Value) (transaction_fresh T)"
using x T_adm unfolding admissible_transaction_def by fast
hence x_val: "fst x = TAtom Value" using x unfolding list_all_iff by blast
have "σ x ⋅ ℐ ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))"
proof (rule ccontr)
assume "¬σ x ⋅ ℐ ∉ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))"
then have a: "σ x ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))"
by auto
then have σ_x_I_in_A: "σ x ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜) ⋅⇩s⇩e⇩t ℐ"
using reachable_constraints_subterms_subst[OF 𝒜_reach ℐ' P] by blast
have "∃u. u ∈ fv⇩l⇩s⇩s⇩t 𝒜 ∧ ℐ u = σ x"
proof -
from σ_x_I_in_A have "∃tu. tu ∈ ⋃ (subterms ` (trms⇩l⇩s⇩s⇩t 𝒜)) ∧ tu ⋅ ℐ = σ x ⋅ ℐ"
by force
then obtain tu where tu: "tu ∈ ⋃ (subterms ` (trms⇩l⇩s⇩s⇩t 𝒜)) ∧ tu ⋅ ℐ = σ x ⋅ ℐ"
by auto
then have "tu ≠ σ x"
using σ_x_nin_A by auto
moreover
have "tu ⋅ ℐ = σ x"
using tu by (simp add: xn)
ultimately
have "∃u. tu = Var u"
unfolding xn by (cases tu) auto
then obtain u where "tu = Var u"
by auto
have "u ∈ fv⇩l⇩s⇩s⇩t 𝒜 ∧ ℐ u = σ x"
proof -
have "u ∈ vars⇩l⇩s⇩s⇩t 𝒜"
using ‹tu = Var u› tu var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t by fastforce
then have "u ∈ fv⇩l⇩s⇩s⇩t 𝒜"
using be vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"] by blast
moreover
have "ℐ u = σ x"
using ‹tu = Var u› ‹tu ⋅ ℐ = σ x› by auto
ultimately
show ?thesis
by auto
qed
then show "∃u. u ∈ fv⇩l⇩s⇩s⇩t 𝒜 ∧ ℐ u = σ x"
by metis
qed
then obtain u where u:
"u ∈ fv⇩l⇩s⇩s⇩t 𝒜" "ℐ u = σ x"
by auto
then have u_TA: "Γ⇩v u = TAtom Value"
using P(1) T x_val Γ⇩v_TAtom''(2)[of x]
wt_subst_trm''[OF ℐ_wt, of "Var u"] wt_subst_trm''[of σ "Var x"]
transaction_fresh_subst_wt[OF σ] protocol_transaction_vars_TAtom_typed(3)
by force
have "∃B. prefix B 𝒜 ∧ u ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
using u u_TA
by (metis welltyped_constraint_model_prefix[OF ℐ]
constraint_model_Value_var_in_constr_prefix[OF 𝒜_reach _ P])
then obtain B where "prefix B 𝒜 ∧ u ∉ fv⇩l⇩s⇩s⇩t B ∧ ℐ u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t B)"
by blast
moreover have "⋃(subterms ` trms⇩l⇩s⇩s⇩t xs) ⊆ ⋃(subterms ` trms⇩l⇩s⇩s⇩t ys)"
when "prefix xs ys"
for xs ys::"('fun,'atom,'sets,'lbl) prot_strand"
using that subterms⇩s⇩e⇩t_mono trms⇩s⇩s⇩t_mono unlabel_mono set_mono_prefix by metis
ultimately have "ℐ u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
by blast
then have "σ x ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
using u by auto
then show "False"
using σ_x_nin_A by auto
qed
then show ?A
unfolding subst_compose_def xn by auto
from ** show ?B
proof
define T' where "T' ≡ transaction_receive T"
define θ where "θ ≡ σ ∘⇩s α"
assume y: "y ∈ fv⇩l⇩s⇩s⇩t (transaction_receive T)"
hence "Var y ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t T')" by (metis T'_def fv⇩s⇩s⇩t_is_subterm_trms⇩s⇩s⇩t)
then obtain z where z: "z ∈ set (unlabel T')" "Var y ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p z)"
by (induct T') auto
have "is_Receive z"
using T_adm Ball_set[of "unlabel T'" is_Receive] z(1)
unfolding admissible_transaction_def wellformed_transaction_def T'_def
by blast
then obtain ty where "z = receive⟨ty⟩" by (cases z) auto
hence ty: "receive⟨ty ⋅ θ⟩ ∈ set (unlabel (T' ⋅⇩l⇩s⇩s⇩t θ))" "θ y ∈ subterms (ty ⋅ θ)"
using z subst_mono unfolding subst_apply_labeled_stateful_strand_def unlabel_def by force+
hence y_deduct: "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊢ ty ⋅ θ ⋅ ℐ"
using transaction_receive_deduct[OF T_adm _ σ α]
by (metis ℐ T'_def θ_def welltyped_constraint_model_def)
obtain zn where zn: "(σ ∘⇩s α) y ⋅ ℐ = Fun (Val (zn, False)) []"
using transaction_var_becomes_Val[
OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ σ α P T, of y]
transaction_fresh_subst_transaction_renaming_subst_range(2)[OF σ α *]
y_fv y_val
by (metis subst_apply_term.simps(1))
have "(σ ∘⇩s α) y ⋅ ℐ ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ)"
using private_fun_deduct_in_ik[OF y_deduct, of "Val (zn, False)"]
by (metis θ_def ty(2) zn subst_mono public.simps(3) snd_eqD)
thus ?B
using ik⇩s⇩s⇩t_subst[of "unlabel 𝒜" ℐ] unlabel_subst[of 𝒜 ℐ]
subterms⇩s⇩e⇩t_mono[OF ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset[of "unlabel (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ)"]]
by fastforce
next
assume y': "y ∈ fv⇩l⇩s⇩s⇩t (transaction_selects T)"
then obtain s where s: "select⟨Var y,s⟩ ∈ set (unlabel (transaction_selects T))"
"fst y = TAtom Value"
using admissible_transaction_strand_step_cases(1,2)[OF T_adm] by fastforce
obtain z zn where zn: "(σ ∘⇩s α) y = Var z" "ℐ z = Fun (Val zn) []"
using transaction_var_becomes_Val[
OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ σ α P T]
transaction_fresh_subst_transaction_renaming_subst_range(2)[OF σ α *]
y_fv T_no_bvars(1) s(2)
by (metis subst_apply_term.simps(1))
have transaction_selects_db_here:
"⋀n s. select⟨Var (TAtom Value, n), Fun (Set s) []⟩ ∈ set (unlabel (transaction_selects T))
⟹ (α (TAtom Value, n) ⋅ ℐ, Fun (Set s) []) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using transaction_selects_db[OF T_adm _ σ α] ℐ
unfolding welltyped_constraint_model_def by auto
have "∃n. y = (Var Value, n)"
using T Γ⇩v_TAtom_inv(2) y_fv y(2)
by blast
moreover
have "admissible_transaction_selects T"
using T_adm admissible_transaction_def
by blast
then have "is_Fun_Set (the_set_term (select⟨Var y,s⟩))"
using s unfolding admissible_transaction_selects_def
by auto
then have "∃ss. s = Fun (Set ss) []"
using is_Fun_Set_exi
by auto
ultimately
obtain n ss where nss: "y = (TAtom Value, n)" "s = Fun (Set ss) []"
by auto
then have "select⟨Var (TAtom Value, n), Fun (Set ss) []⟩ ∈ set (unlabel (transaction_selects T))"
using s by auto
then have in_db: "(α (TAtom Value, n) ⋅ ℐ, Fun (Set ss) []) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using transaction_selects_db_here[of n ss] by auto
have "(ℐ z, s) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
proof -
have "(α y ⋅ ℐ, s) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
using in_db nss by auto
moreover
have "α y = Var z"
using zn
by (metis (no_types, hide_lams) σ subst_compose_def subst_imgI subst_to_var_is_var
term.distinct(1) transaction_fresh_subst_def var_comp(2))
then have "α y ⋅ ℐ = ℐ z"
by auto
ultimately
show "(ℐ z, s) ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
by auto
qed
then have "∃t' s'. insert⟨t',s'⟩ ∈ set (unlabel 𝒜) ∧ ℐ z = t' ⋅ ℐ ∧ s = s' ⋅ ℐ"
using db⇩s⇩s⇩t_in_cases[of "ℐ z" s "unlabel 𝒜" ℐ "[]"] unfolding db⇩s⇩s⇩t_def by auto
then obtain t' s' where t's': "insert⟨t',s'⟩ ∈ set (unlabel 𝒜) ∧ ℐ z = t' ⋅ ℐ ∧ s = s' ⋅ ℐ"
by auto
then have "t' ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)"
by force
then have "t' ⋅ ℐ ∈ (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)) ⋅⇩s⇩e⇩t ℐ"
by auto
then have "ℐ z ∈ (subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)) ⋅⇩s⇩e⇩t ℐ"
using t's' by auto
then have "ℐ z ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜 ⋅⇩l⇩s⇩s⇩t ℐ))"
using reachable_constraints_subterms_subst[
OF 𝒜_reach welltyped_constraint_model_prefix[OF ℐ] P]
by auto
then show ?B
using zn(1) by simp
qed
qed
lemma transaction_prop5:
fixes T σ α 𝒜 ℐ T' a0 a0' θ
defines "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
and "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
and "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@T') ℐ)"
and "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@T')"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
and step: "list_all (transaction_check FP OCC TI) P"
shows "∃δ ∈ abs_substs_fun ` set (transaction_check_comp FP OCC TI T).
∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ⟶
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc (δ x) ∧
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0' = absc (absdbupd (unlabel (transaction_updates T)) x (δ x))"
proof -
define comp0 where "comp0 ≡ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
define check0 where "check0 ≡ transaction_check FP OCC TI T"
define upd where "upd ≡ λδ x. absdbupd (unlabel (transaction_updates T)) x (δ x)"
define b0 where "b0 ≡ λx. THE b. absc b = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0"
note all_defs = comp0_def check0_def a0_def a0'_def upd_def b0_def θ_def T'_def
have θ_wt: "wt⇩s⇩u⇩b⇩s⇩t (θ δ)" for δ
unfolding θ_def wt⇩s⇩u⇩b⇩s⇩t_def
by fastforce
have 𝒜_wf⇩t⇩r⇩m⇩s: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
by (metis reachable_constraints_wf⇩t⇩r⇩m⇩s admissible_transactions_wf⇩t⇩r⇩m⇩s P(1) 𝒜_reach)
have ℐ_interp: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ"
and ℐ_wf_trms: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
by (metis ℐ welltyped_constraint_model_def constraint_model_def,
metis ℐ welltyped_constraint_model_def,
metis ℐ welltyped_constraint_model_def constraint_model_def)
have ℐ_is_T_model: "strand_sem_stateful (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) (set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)) (unlabel T') ℐ"
using ℐ unlabel_append[of 𝒜 T'] db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t[of "unlabel 𝒜" ℐ "[]"]
strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "unlabel T'" ℐ]
by (simp add: welltyped_constraint_model_def constraint_model_def db⇩s⇩s⇩t_def)
have T_adm: "admissible_transaction T"
using T P(1) Ball_set[of P "admissible_transaction"]
by blast
hence T_valid: "wellformed_transaction T"
unfolding admissible_transaction_def by blast
have T_no_bvars: "fv_transaction T = vars_transaction T" "bvars_transaction T = {}"
using transaction_no_bvars[OF T_adm] by simp_all
have T_vars_const_typed: "∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ∨ (∃a. Γ⇩v x = TAtom (Atom a))"
and T_fresh_vars_value_typed: "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
using T P protocol_transaction_vars_TAtom_typed(2,3)[of T] by simp_all
have wt_σαℐ: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α ∘⇩s ℐ)" and wt_σα: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using ℐ_wt wt_subst_compose transaction_fresh_subst_wt[OF σ T_fresh_vars_value_typed]
transaction_renaming_subst_wt[OF α]
by blast+
have T_vars_vals: "∀x ∈ fv_transaction T. ∃n. (σ ∘⇩s α) x ⋅ ℐ = Fun (Val (n, False)) []"
proof
fix x assume x: "x ∈ fv_transaction T"
show "∃n. (σ ∘⇩s α) x ⋅ ℐ = Fun (Val (n, False)) []"
proof (cases "x ∈ subst_domain σ")
case True
then obtain n where "σ x = Fun (Val (n, False)) []"
using σ unfolding transaction_fresh_subst_def
by moura
thus ?thesis by (simp add: subst_compose_def)
next
case False
hence *: "(σ ∘⇩s α) x = α x" by (auto simp add: subst_compose_def)
obtain y where y: "Γ⇩v x = Γ⇩v y" "α x = Var y"
using transaction_renaming_subst_wt[OF α]
transaction_renaming_subst_is_renaming[OF α]
by (metis Γ.simps(1) prod.exhaust wt⇩s⇩u⇩b⇩s⇩t_def)
hence "y ∈ fv⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
using x * T_no_bvars(2) unlabel_subst[of "transaction_strand T" "σ ∘⇩s α"]
fv⇩s⇩s⇩t_subst_fv_subset[of x "unlabel (transaction_strand T)" "σ ∘⇩s α"]
by auto
hence "y ∈ fv⇩l⇩s⇩s⇩t (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
using fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
fv⇩s⇩s⇩t_append[of "unlabel 𝒜"] unlabel_append[of 𝒜]
by auto
thus ?thesis
using x y * T P
constraint_model_Value_term_is_Val[
OF reachable_constraints.step[OF 𝒜_reach T σ α] ℐ[unfolded T'_def] P(1), of y]
admissible_transaction_Value_vars[of T]
by simp
qed
qed
have T_vars_absc: "∀x ∈ fv_transaction T. ∃!n. (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc n"
using T_vars_vals by fastforce
hence "(absc ∘ b0) x = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0" when "x ∈ fv_transaction T" for x
using that unfolding b0_def by fastforce
hence T_vars_absc': "t ⋅ (absc ∘ b0) = t ⋅ (σ ∘⇩s α) ⋅ ℐ ⋅⇩α a0"
when "fv t ⊆ fv_transaction T" "∄n T. Fun (Val n) T ∈ subterms t" for t
using that(1) abs_term_subst_eq'[OF _ that(2), of "σ ∘⇩s α ∘⇩s ℐ" a0 "absc ∘ b0"]
subst_compose[of "σ ∘⇩s α" ℐ] subst_subst_compose[of t "σ ∘⇩s α" ℐ]
by fastforce
have "∃δ ∈ comp0. ∀x ∈ fv_transaction T. fst x = TAtom Value ⟶ b0 x = δ x"
proof -
let ?S = "set (unlabel (transaction_selects T))"
let ?C = "set (unlabel (transaction_checks T))"
let ?xs = "fv_transaction T - set (transaction_fresh T)"
note * = transaction_prop3[OF 𝒜_reach T ℐ[unfolded T'_def] σ α FP OCC TI P(1)]
have **:
"∀x ∈ set (transaction_fresh T). b0 x = {}"
"∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ b0)"
(is ?B)
proof -
show ?B
proof (intro ballI impI)
fix t assume t: "t ∈ trms⇩l⇩s⇩s⇩t (transaction_receive T)"
hence t': "fv t ⊆ fv_transaction T" "∄n T. Fun (Val n) T ∈ subterms t"
using trms_transaction_unfold[of T] vars_transaction_unfold[of T]
trms⇩s⇩s⇩t_fv_vars⇩s⇩s⇩t_subset[of t "unlabel (transaction_strand T)"]
transactions_have_no_Value_consts'[OF T_adm]
wellformed_transaction_send_receive_fv_subset(1)[OF T_valid t(1)]
by blast+
have "intruder_synth_mod_timpls FP TI (t ⋅ (absc ∘ b0))"
using t(1) t' *(2) T_vars_absc'
by (metis a0_def)
moreover have "(absc ∘ b0) x = (θ b0) x" when "x ∈ fv t" for x
using that T P admissible_transaction_Value_vars[of T]
‹fv t ⊆ fv_transaction T› Γ⇩v_TAtom''(2)[of x]
unfolding θ_def by fastforce
hence "t ⋅ (absc ∘ b0) = t ⋅ θ b0"
using term_subst_eq[of t "absc ∘ b0" "θ b0"] by argo
ultimately show "intruder_synth_mod_timpls FP TI (t ⋅ θ b0)"
using intruder_synth.simps[of "set FP"] by (cases "t ⋅ θ b0") metis+
qed
qed (simp add: *(1) a0_def b0_def)
have ***: "∀x ∈ ?xs. ∀s. select⟨Var x,Fun (Set s) []⟩ ∈ ?S ⟶ s ∈ b0 x"
"∀x ∈ ?xs. ∀s. ⟨Var x in Fun (Set s) []⟩ ∈ ?C ⟶ s ∈ b0 x"
"∀x ∈ ?xs. ∀s. ⟨Var x not in Fun (Set s) []⟩ ∈ ?C ⟶ s ∉ b0 x"
"∀x ∈ ?xs. fst x = TAtom Value ⟶ b0 x ∈ set OCC"
unfolding a0_def b0_def
using *(3,4) apply (force, force)
using *(5) apply force
using *(6) admissible_transaction_Value_vars[OF bspec[OF P T]] by force
show ?thesis
using transaction_check_comp_in[OF T_adm **[unfolded θ_def] ***]
unfolding comp0_def
by metis
qed
hence 1: "∃δ ∈ comp0. ∀x ∈ fv_transaction T.
fst x = TAtom Value ⟶ (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc (δ x)"
using T_vars_absc unfolding b0_def a0_def by fastforce
obtain δ where δ:
"δ ∈ comp0" "∀x ∈ fv_transaction T. fst x = TAtom Value ⟶ (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc (δ x)"
using 1 by moura
have 2: "θ x ⋅ ℐ ⋅⇩α α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) = absc (absdbupd (unlabel A) x d)"
when "θ x ⋅ ℐ ⋅⇩α α⇩0 D = absc d"
and "∀t u. insert⟨t,u⟩ ∈ set (unlabel A) ⟶ (∃y s. t = Var y ∧ u = Fun (Set s) [])"
and "∀t u. delete⟨t,u⟩ ∈ set (unlabel A) ⟶ (∃y s. t = Var y ∧ u = Fun (Set s) [])"
and "∀y ∈ fv⇩l⇩s⇩s⇩t A. θ x ⋅ ℐ = θ y ⋅ ℐ ⟶ x = y"
and "∀y ∈ fv⇩l⇩s⇩s⇩t A. ∃n. θ y ⋅ ℐ = Fun (Val n) []"
and x: "θ x ⋅ ℐ = Fun (Val n) []"
and D: "∀d ∈ set D. ∃s. snd d = Fun (Set s) []"
for A::"('fun,'atom,'sets,'nat) prot_strand" and x θ D n d
using that(2,3,4,5)
proof (induction A rule: List.rev_induct)
case (snoc a A)
then obtain l b where a: "a = (l,b)" by (metis surj_pair)
have IH: "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n = absdbupd (unlabel A) x d"
using snoc unlabel_append[of A "[a]"] a x
by (simp del: unlabel_append)
have b_prems: "∀y ∈ fv⇩s⇩s⇩t⇩p b. θ x ⋅ ℐ = θ y ⋅ ℐ ⟶ x = y"
"∀y ∈ fv⇩s⇩s⇩t⇩p b. ∃n. θ y ⋅ ℐ = Fun (Val n) []"
using snoc.prems(3,4) a by (simp_all add: unlabel_def)
have *: "filter is_Update (unlabel (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ))) =
filter is_Update (unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)))"
"filter is_Update (unlabel (A@[a])) = filter is_Update (unlabel A)"
when "¬is_Update b"
using that a
by (cases b, simp_all add: dual⇩l⇩s⇩s⇩t_def unlabel_def subst_apply_labeled_stateful_strand_def)+
note ** = IH a dual⇩l⇩s⇩s⇩t_subst_append[of A "[a]" θ]
note *** = * absdbupd_filter[of "unlabel (A@[a])"]
absdbupd_filter[of "unlabel A"]
db⇩s⇩s⇩t_filter[of "unlabel (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ))"]
db⇩s⇩s⇩t_filter[of "unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ))"]
note **** = **(2,3) dual⇩l⇩s⇩s⇩t_subst_snoc[of A a θ]
unlabel_append[of "dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ" "[dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p θ]"]
db⇩s⇩s⇩t_append[of "unlabel (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ)" "unlabel [dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p θ]" ℐ D]
have "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n = absdbupd (unlabel (A@[a])) x d" using ** ***
proof (cases b)
case (Insert t t')
then obtain y s m where y: "t = Var y" "t' = Fun (Set s) []" "θ y ⋅ ℐ = Fun (Val m) []"
using snoc.prems(1) b_prems(2) a by (fastforce simp add: unlabel_def)
hence a': "db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D =
List.insert ((Fun (Val m) [], Fun (Set s) [])) (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D)"
"unlabel [dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p θ] = [insert⟨θ y, Fun (Set s) []⟩]"
"unlabel [a] = [insert⟨Var y, Fun (Set s) []⟩]"
using **** Insert by simp_all
show ?thesis
proof (cases "x = y")
case True
hence "θ x ⋅ ℐ = θ y ⋅ ℐ" by simp
hence "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n =
insert s (α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n)"
by (metis (no_types, lifting) y(3) a'(1) x dual⇩l⇩s⇩s⇩t_subst to_abs_list_insert')
thus ?thesis using True IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
next
case False
hence "θ x ⋅ ℐ ≠ θ y ⋅ ℐ" using b_prems(1) y Insert by simp
hence "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n = α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n"
by (metis (no_types, lifting) y(3) a'(1) x dual⇩l⇩s⇩s⇩t_subst to_abs_list_insert)
thus ?thesis using False IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
qed
next
case (Delete t t')
then obtain y s m where y: "t = Var y" "t' = Fun (Set s) []" "θ y ⋅ ℐ = Fun (Val m) []"
using snoc.prems(2) b_prems(2) a by (fastforce simp add: unlabel_def)
hence a': "db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D =
List.removeAll ((Fun (Val m) [], Fun (Set s) [])) (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D)"
"unlabel [dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p θ] = [delete⟨θ y, Fun (Set s) []⟩]"
"unlabel [a] = [delete⟨Var y, Fun (Set s) []⟩]"
using **** Delete by simp_all
have "∃s S. snd d = Fun (Set s) []" when "d ∈ set (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D)" for d
using snoc.prems(1,2) db⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t_set_ex[OF that _ _ D] by (simp add: unlabel_def)
moreover {
fix t::"('fun,'atom,'sets) prot_term"
and D::"(('fun,'atom,'sets) prot_term × ('fun,'atom,'sets) prot_term) list"
assume "∀d ∈ set D. ∃s. snd d = Fun (Set s) []"
hence "removeAll (t, Fun (Set s) []) D = filter (λd. ∄S. d = (t, Fun (Set s) S)) D"
by (induct D) auto
} ultimately have a'':
"List.removeAll ((Fun (Val m) [], Fun (Set s) [])) (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D) =
filter (λd. ∄S. d = (Fun (Val m) [], Fun (Set s) S)) (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t θ) ℐ D)"
by simp
show ?thesis
proof (cases "x = y")
case True
hence "θ x ⋅ ℐ = θ y ⋅ ℐ" by simp
hence "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n =
(α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n) - {s}"
using y(3) a'' a'(1) x by (simp add: dual⇩l⇩s⇩s⇩t_subst to_abs_list_remove_all')
thus ?thesis using True IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
next
case False
hence "θ x ⋅ ℐ ≠ θ y ⋅ ℐ" using b_prems(1) y Delete by simp
hence "α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n = α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)) ℐ D) n"
by (metis (no_types, lifting) y(3) a'(1) x dual⇩l⇩s⇩s⇩t_subst to_abs_list_remove_all)
thus ?thesis using False IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
qed
qed simp_all
thus ?case by (simp add: x)
qed (simp add: that(1))
have 3: "x = y"
when xy: "(σ ∘⇩s α) x ⋅ ℐ = (σ ∘⇩s α) y ⋅ ℐ" "x ∈ fv_transaction T" "y ∈ fv_transaction T"
for x y
proof -
have "x ∉ set (transaction_fresh T) ⟹ y ∉ set (transaction_fresh T) ⟹ ?thesis"
using xy admissible_transaction_strand_sem_fv_ineq[OF T_adm ℐ_is_T_model[unfolded T'_def]]
by fast
moreover {
assume *: "x ∈ set (transaction_fresh T)" "y ∈ set (transaction_fresh T)"
then obtain xn yn where "σ x = Fun (Val xn) []" "σ y = Fun (Val yn) []"
by (metis transaction_fresh_subst_sends_to_val[OF σ])
hence "σ x = σ y" using that(1) by (simp add: subst_compose)
moreover have "inj_on σ (subst_domain σ)" "x ∈ subst_domain σ" "y ∈ subst_domain σ"
using * σ unfolding transaction_fresh_subst_def by auto
ultimately have ?thesis unfolding inj_on_def by blast
} moreover have False when "x ∈ set (transaction_fresh T)" "y ∉ set (transaction_fresh T)"
using that(2) xy T_no_bvars admissible_transaction_Value_vars[OF bspec[OF P T], of y]
transaction_prop4[OF 𝒜_reach T ℐ[unfolded T'_def] σ α P that(1), of y]
by auto
moreover have False when "x ∉ set (transaction_fresh T)" "y ∈ set (transaction_fresh T)"
using that(1) xy T_no_bvars admissible_transaction_Value_vars[OF bspec[OF P T], of x]
transaction_prop4[OF 𝒜_reach T ℐ[unfolded T'_def] σ α P that(2), of x]
by fastforce
ultimately show ?thesis by metis
qed
have 4: "∃y s. t = Var y ∧ u = Fun (Set s) []"
when "insert⟨t,u⟩ ∈ set (unlabel (transaction_strand T))" for t u
using that admissible_transaction_strand_step_cases(4)[OF T_adm] T_valid
by blast
have 5: "∃y s. t = Var y ∧ u = Fun (Set s) []"
when "delete⟨t,u⟩ ∈ set (unlabel (transaction_strand T))" for t u
using that admissible_transaction_strand_step_cases(4)[OF T_adm] T_valid
by blast
have 6: "∃n. (σ ∘⇩s α) y ⋅ ℐ = Fun (Val (n, False)) []" when "y ∈ fv_transaction T" for y
using that by (simp add: T_vars_vals)
have "list_all wellformed_transaction P" "list_all admissible_transaction_updates P"
using P(1) Ball_set[of P "admissible_transaction"] Ball_set[of P wellformed_transaction]
Ball_set[of P admissible_transaction_updates]
unfolding admissible_transaction_def by fastforce+
hence 7: "∃s. snd d = Fun (Set s) []" when "d ∈ set (db⇩l⇩s⇩s⇩t 𝒜 ℐ)" for d
using that reachable_constraints_db⇩l⇩s⇩s⇩t_set_args_empty[OF 𝒜_reach]
unfolding admissible_transaction_updates_def by (cases d) simp
have "(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0' = absc (upd δ x)"
when x: "x ∈ fv_transaction T" "fst x = TAtom Value" for x
proof -
have "(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α α⇩0 (db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ (db⇩l⇩s⇩s⇩t 𝒜 ℐ))
= absc (absdbupd (unlabel (transaction_strand T)) x (δ x))"
using 2[of "σ ∘⇩s α" x "db⇩l⇩s⇩s⇩t 𝒜 ℐ" "δ x" "transaction_strand T"]
3[OF _ x(1)] 4 5 6[OF that(1)] 6 7 x δ(2)
unfolding all_defs by blast
thus ?thesis
using x db⇩s⇩s⇩t_append[of "unlabel 𝒜"] absdbupd_wellformed_transaction[OF T_valid]
unfolding all_defs db⇩s⇩s⇩t_def by force
qed
thus ?thesis using δ Γ⇩v_TAtom''(2) unfolding all_defs by blast
qed
lemma transaction_prop6:
fixes T σ α 𝒜 ℐ T' a0 a0'
defines "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
and "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
and "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@T') ℐ)"
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@T')"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
and step: "list_all (transaction_check FP OCC TI) P"
shows "∀t ∈ timpl_closure_set (α⇩i⇩k 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ).
timpl_closure_set (set FP) (set TI) ⊢⇩c t" (is ?A)
and "timpl_closure_set (α⇩v⇩a⇩l⇩s 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ) ⊆ absc ` set OCC" (is ?B)
and "∀t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T). is_Fun (t ⋅ (σ ∘⇩s α) ⋅ ℐ ⋅⇩α a0') ⟶
timpl_closure_set (set FP) (set TI) ⊢⇩c t ⋅ (σ ∘⇩s α) ⋅ ℐ ⋅⇩α a0'" (is ?C)
and "∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ⟶
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0' ∈ absc ` set OCC" (is ?D)
proof -
define comp0 where "comp0 ≡ abs_substs_fun ` set (transaction_check_comp FP OCC TI T)"
define check0 where "check0 ≡ transaction_check FP OCC TI T"
define upd where "upd ≡ λδ x. absdbupd (unlabel (transaction_updates T)) x (δ x)"
define θ where "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
have T_adm: "admissible_transaction T" using T P(1) by metis
hence T_valid: "wellformed_transaction T" by (metis admissible_transaction_def)
have θ_prop: "θ σ x = absc (σ x)" when "Γ⇩v x = TAtom Value" for σ x
using that Γ⇩v_TAtom''(2)[of x] unfolding θ_def by simp
have 0: "∃δ ∈ comp0. ∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ⟶
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc (δ x) ∧
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0' = absc (upd δ x)"
using transaction_prop5[OF 𝒜_reach T ℐ[unfolded T'_def] σ α FP OCC TI P step]
unfolding a0_def a0'_def T'_def upd_def comp0_def
by blast
have 1: "(δ x, upd δ x) ∈ (set TI)⇧+"
when "δ ∈ comp0" "δ x ≠ upd δ x" "x ∈ fv_transaction T" "x ∉ set (transaction_fresh T)"
for x δ
using T that step Ball_set[of P "transaction_check FP OCC TI"]
transaction_prop1[of δ FP OCC TI T x] TI
unfolding upd_def comp0_def
by blast
have 2: "upd δ x ∈ set OCC"
when "δ ∈ comp0" "x ∈ fv_transaction T" "fst x = TAtom Value" for x δ
using T that step Ball_set[of P "transaction_check FP OCC TI"]
T_adm FP OCC TI transaction_prop2[of δ FP OCC TI T x]
unfolding upd_def comp0_def
by blast+
obtain δ where δ:
"δ ∈ comp0"
"∀x ∈ fv_transaction T. Γ⇩v x = TAtom Value ⟶
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0 = absc (δ x) ∧
(σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0' = absc (upd δ x)"
using 0 by moura
have "∃x. ab = (δ x, upd δ x) ∧ x ∈ fv_transaction T - set (transaction_fresh T) ∧ δ x ≠ upd δ x"
when ab: "ab ∈ α⇩t⇩i 𝒜 T σ α ℐ" for ab
proof -
obtain a b where ab': "ab = (a,b)" by (metis surj_pair)
then obtain x where x:
"a ≠ b" "x ∈ fv_transaction T" "x ∉ set (transaction_fresh T)"
"absc a = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0" "absc b = (σ ∘⇩s α) x ⋅ ℐ ⋅⇩α a0'"
using ab unfolding abs_term_implications_def a0_def a0'_def T'_def by blast
hence "absc a = absc (δ x)" "absc b = absc (upd δ x)"
using δ(2) admissible_transaction_Value_vars[OF bspec[OF P T] x(2)]
by metis+
thus ?thesis using x ab' by blast
qed
hence α⇩t⇩i_TI_subset: "α⇩t⇩i 𝒜 T σ α ℐ ⊆ {(a,b) ∈ (set TI)⇧+. a ≠ b}" using 1[OF δ(1)] by blast
have "timpl_closure_set (timpl_closure_set (set FP) (set TI)) (α⇩t⇩i 𝒜 T σ α ℐ) ⊢⇩c t"
when t: "t ∈ timpl_closure_set (α⇩i⇩k 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ)" for t
using timpl_closure_set_is_timpl_closure_union[of "α⇩i⇩k 𝒜 ℐ" "α⇩t⇩i 𝒜 T σ α ℐ"]
intruder_synth_timpl_closure_set FP(3) t
by blast
thus ?A
using ideduct_synth_mono[OF _ timpl_closure_set_mono[OF
subset_refl[of "timpl_closure_set (set FP) (set TI)"]
α⇩t⇩i_TI_subset]]
timpl_closure_set_timpls_trancl_eq'[of "timpl_closure_set (set FP) (set TI)" "set TI"]
unfolding timpl_closure_set_idem
by force
have "timpl_closure_set (α⇩v⇩a⇩l⇩s 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ) ⊆
timpl_closure_set (absc ` set OCC) {(a,b) ∈ (set TI)⇧+. a ≠ b}"
using timpl_closure_set_mono[OF _ α⇩t⇩i_TI_subset] OCC(3) by blast
thus ?B using OCC(2) timpl_closure_set_timpls_trancl_subset' by blast
have "transaction_check_post FP TI T δ"
using T δ(1) step
unfolding transaction_check_def comp0_def list_all_iff
by blast
hence 3: "timpl_closure_set (set FP) (set TI) ⊢⇩c t ⋅ θ (upd δ)"
when "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" "is_Fun (t ⋅ θ (upd δ))" for t
using that
unfolding transaction_check_post_def upd_def θ_def
intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, symmetric]
by meson
have 4: "∀x ∈ fv t. (σ ∘⇩s α ∘⇩s ℐ) x ⋅⇩α a0' = θ (upd δ) x"
when "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" for t
using wellformed_transaction_send_receive_fv_subset(2)[OF T_valid that]
δ(2) subst_compose[of "σ ∘⇩s α" ℐ] θ_prop
admissible_transaction_Value_vars[OF bspec[OF P T]]
by fastforce
have 5: "∄n T. Fun (Val n) T ∈ subterms t" when "t ∈ trms⇩l⇩s⇩s⇩t (transaction_send T)" for t
using that transactions_have_no_Value_consts'[OF T_adm] trms_transaction_unfold[of T]
by blast
show ?D using 2[OF δ(1)] δ(2) Γ⇩v_TAtom''(2) unfolding a0'_def T'_def by blast
show ?C using 3 abs_term_subst_eq'[OF 4 5] by simp
qed
lemma reachable_constraints_covered_step:
fixes 𝒜::"('fun,'atom,'sets,'lbl) prot_constr"
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and T: "T ∈ set P"
and ℐ: "welltyped_constraint_model ℐ (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α))"
and σ: "transaction_fresh_subst σ T 𝒜"
and α: "transaction_renaming_subst α P 𝒜"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
"ground (set FP)"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
and transactions_covered: "list_all (transaction_check FP OCC TI) P"
shows "∀t ∈ α⇩i⇩k (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ.
timpl_closure_set (set FP) (set TI) ⊢⇩c t" (is ?A)
and "α⇩v⇩a⇩l⇩s (𝒜@dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)) ℐ ⊆ absc ` set OCC" (is ?B)
proof -
note step_props = transaction_prop6[OF 𝒜_reach T ℐ σ α FP(1,2,3) OCC TI P transactions_covered]
define T' where "T' ≡ dual⇩l⇩s⇩s⇩t (transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α)"
define a0 where "a0 ≡ α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)"
define a0' where "a0' ≡ α⇩0 (db⇩l⇩s⇩s⇩t (𝒜@T') ℐ)"
define vals where "vals ≡ λS::('fun,'atom,'sets,'lbl) prot_constr.
{t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S) ⋅⇩s⇩e⇩t ℐ. ∃n. t = Fun (Val n) []}"
define vals_sym where "vals_sym ≡ λS::('fun,'atom,'sets,'lbl) prot_constr.
{t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S). (∃n. t = Fun (Val n) []) ∨ (∃m. t = Var (TAtom Value,m))}"
have ℐ_wt: "wt⇩s⇩u⇩b⇩s⇩t ℐ" by (metis ℐ welltyped_constraint_model_def)
have ℐ_grounds: "fv (t ⋅ ℐ) = {}" for t
using ℐ interpretation_grounds[of ℐ]
unfolding welltyped_constraint_model_def constraint_model_def by auto
have T_fresh_vars_value_typed: "∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
using protocol_transaction_vars_TAtom_typed[OF bspec[OF P(1) T]] by simp_all
have wt_σαℐ: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α ∘⇩s ℐ)" and wt_σα: "wt⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s α)"
using ℐ_wt wt_subst_compose transaction_fresh_subst_wt[OF σ T_fresh_vars_value_typed]
transaction_renaming_subst_wt[OF α]
by blast+
have "∀T∈set P. bvars_transaction T = {}"
using P unfolding list_all_iff admissible_transaction_def by metis
hence 𝒜_no_bvars: "bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using reachable_constraints_no_bvars[OF 𝒜_reach] by metis
have ℐ_vals: "∃n. ℐ (TAtom Value, m) = Fun (Val n) []"
when "(TAtom Value, m) ∈ fv⇩l⇩s⇩s⇩t 𝒜" for m
using constraint_model_Value_term_is_Val'[
OF 𝒜_reach welltyped_constraint_model_prefix[OF ℐ] P(1)]
𝒜_no_bvars vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel 𝒜"] that
by blast
have vals_sym_vals: "t ⋅ ℐ ∈ vals 𝒜" when t: "t ∈ vals_sym 𝒜" for t
proof (cases t)
case (Var x)
then obtain m where *: "x = (TAtom Value,m)" using t unfolding vals_sym_def by blast
moreover have "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" using t unfolding vals_sym_def by blast
hence "t ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜) ⋅⇩s⇩e⇩t ℐ" "∃n. ℐ (Var Value, m) = Fun (Val n) []"
using Var * ℐ_vals[of m] var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t[of x "unlabel 𝒜"]
Γ⇩v_TAtom[of Value m] reachable_constraints_Value_vars_are_fv[OF 𝒜_reach P(1), of x]
by blast+
ultimately show ?thesis using Var unfolding vals_def by auto
next
case (Fun f T)
then obtain n where "f = Val n" "T = []" using t unfolding vals_sym_def by blast
moreover have "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" using t unfolding vals_sym_def by blast
hence "t ⋅ ℐ ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜) ⋅⇩s⇩e⇩t ℐ" using Fun by blast
ultimately show ?thesis using Fun unfolding vals_def by auto
qed
have vals_vals_sym: "∃s. s ∈ vals_sym 𝒜 ∧ t = s ⋅ ℐ" when "t ∈ vals 𝒜" for t
using that constraint_model_Val_is_Value_term[OF ℐ]
unfolding vals_def vals_sym_def by fast
have T_adm: "admissible_transaction T" and T_valid: "wellformed_transaction T"
apply (metis P(1) T)
using P(1) T Ball_set[of P "admissible_transaction"]
unfolding admissible_transaction_def by fastforce
have 0:
"α⇩i⇩k (𝒜@T') ℐ = (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0' ∪ (ik⇩l⇩s⇩s⇩t T' ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0'"
"α⇩v⇩a⇩l⇩s (𝒜@T') ℐ = vals 𝒜 ⋅⇩α⇩s⇩e⇩t a0' ∪ vals T' ⋅⇩α⇩s⇩e⇩t a0'"
by (metis abs_intruder_knowledge_append a0'_def,
metis abs_value_constants_append[of 𝒜 T' ℐ] a0'_def vals_def)
have 1: "(ik⇩l⇩s⇩s⇩t T' ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0' =
(trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t (σ ∘⇩s α) ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0'"
by (metis T'_def dual_transaction_ik_is_transaction_send''[OF T_valid])
have 2: "bvars⇩l⇩s⇩s⇩t (transaction_strand T) ∩ subst_domain σ = {}"
"bvars⇩l⇩s⇩s⇩t (transaction_strand T) ∩ subst_domain α = {}"
using T_adm unfolding admissible_transaction_def
by blast+
have "vals T' ⊆ (σ ∘⇩s α) ` fv_transaction T ⋅⇩s⇩e⇩t ℐ"
proof
fix t assume "t ∈ vals T'"
then obtain s n where s:
"s ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t T')" "t = s ⋅ ℐ" "t = Fun (Val n) []"
unfolding vals_def by fast
then obtain u where u:
"u ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (transaction_strand T))"
"s = u ⋅ (σ ∘⇩s α)"
using transaction_fresh_subst_transaction_renaming_subst_trms[OF σ α 2]
trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq[of "transaction_strand T ⋅⇩l⇩s⇩s⇩t σ ∘⇩s α"]
unfolding T'_def by blast
have *: "t = u ⋅ (σ ∘⇩s α ∘⇩s ℐ)" by (metis subst_subst_compose s(2) u(2))
then obtain x where x: "u = Var x"
using s(3) transactions_have_no_Value_consts(1)[OF T_adm u(1)] by (cases u) force+
hence **: "x ∈ vars_transaction T"
by (metis u(1) var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t)
have "Γ⇩v x = TAtom Value"
using * x s(3) wt_subst_trm''[OF wt_σαℐ, of u]
by simp
thus "t ∈ (σ ∘⇩s α) ` fv_transaction T ⋅⇩s⇩e⇩t ℐ"
using transaction_Value_vars_are_fv[OF T_adm **] x *
by (metis subst_comp_set_image rev_image_eqI subst_apply_term.simps(1))
qed
hence 3: "vals T' ⋅⇩α⇩s⇩e⇩t a0' ⊆ ((σ ∘⇩s α) ` fv_transaction T ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0'"
by (simp add: abs_apply_terms_def image_mono)
have "t ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set (α⇩i⇩k 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ)"
when "t ∈ ik⇩l⇩s⇩s⇩t 𝒜" for t
using that abs_in[OF imageI[OF that]]
α⇩t⇩i_covers_α⇩0_ik[OF 𝒜_reach T ℐ σ α P(1)]
timpl_closure_set_mono[of "{t ⋅ ℐ ⋅⇩α a0}" "α⇩i⇩k 𝒜 ℐ" "α⇩t⇩i 𝒜 T σ α ℐ" "α⇩t⇩i 𝒜 T σ α ℐ"]
unfolding a0_def a0'_def T'_def abs_intruder_knowledge_def by fast
hence A: "α⇩i⇩k (𝒜@T') ℐ ⊆
timpl_closure_set (α⇩i⇩k 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ) ∪
(trms⇩l⇩s⇩s⇩t (transaction_send T) ⋅⇩s⇩e⇩t (σ ∘⇩s α) ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0'"
using 0(1) 1 by (auto simp add: abs_apply_terms_def)
have "t ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set {t ⋅ ℐ ⋅⇩α a0} (α⇩t⇩i 𝒜 T σ α ℐ)"
when t: "t ∈ vals_sym 𝒜" for t
proof -
have "(∃n. t = Fun (Val n) [] ∧ t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)) ∨
(∃n. t = Var (TAtom Value,n) ∧ (TAtom Value,n) ∈ fv⇩l⇩s⇩s⇩t 𝒜)"
(is "?P ∨ ?Q")
using t var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t[of _ "unlabel 𝒜"]
Γ⇩v_TAtom[of Value] reachable_constraints_Value_vars_are_fv[OF 𝒜_reach P(1)]
unfolding vals_sym_def by fast
thus ?thesis
proof
assume ?P
then obtain n where n: "t = Fun (Val n) []" "t ∈ subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜)" by moura
thus ?thesis
using α⇩t⇩i_covers_α⇩0_Val[OF 𝒜_reach T ℐ σ α P(1), of n]
unfolding a0_def a0'_def T'_def by fastforce
next
assume ?Q
thus ?thesis
using α⇩t⇩i_covers_α⇩0_Var[OF 𝒜_reach T ℐ σ α P(1)]
unfolding a0_def a0'_def T'_def by fastforce
qed
qed
moreover have "t ⋅ ℐ ⋅⇩α a0 ∈ α⇩v⇩a⇩l⇩s 𝒜 ℐ"
when "t ∈ vals_sym 𝒜" for t
using that abs_in vals_sym_vals
unfolding a0_def abs_value_constants_def vals_sym_def vals_def
by (metis (mono_tags, lifting))
ultimately have "t ⋅ ℐ ⋅⇩α a0' ∈ timpl_closure_set (α⇩v⇩a⇩l⇩s 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ)"
when t: "t ∈ vals_sym 𝒜" for t
using t timpl_closure_set_mono[of "{t ⋅ ℐ ⋅⇩α a0}" "α⇩v⇩a⇩l⇩s 𝒜 ℐ" "α⇩t⇩i 𝒜 T σ α ℐ" "α⇩t⇩i 𝒜 T σ α ℐ"]
by blast
hence "t ⋅⇩α a0' ∈ timpl_closure_set (α⇩v⇩a⇩l⇩s 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ)"
when t: "t ∈ vals 𝒜" for t
using vals_vals_sym[OF t] by blast
hence B: "α⇩v⇩a⇩l⇩s (𝒜@T') ℐ ⊆
timpl_closure_set (α⇩v⇩a⇩l⇩s 𝒜 ℐ) (α⇩t⇩i 𝒜 T σ α ℐ) ∪
((σ ∘⇩s α) ` fv_transaction T ⋅⇩s⇩e⇩t ℐ) ⋅⇩α⇩s⇩e⇩t a0'"
using 0(2) 3
by (simp add: abs_apply_terms_def image_subset_iff)
have 4: "fv (t ⋅ σ ∘⇩s α ⋅ ℐ ⋅⇩α a) = {}" for t a
using ℐ_grounds[of "t ⋅ σ ∘⇩s α"] abs_fv[of "t ⋅ σ ∘⇩s α ⋅ ℐ" a]
by argo
have "is_Fun (t ⋅ σ ∘⇩s α ⋅ ℐ ⋅⇩α a0')" for t
using 4[of t a0'] by force
thus ?A
using A step_props(1,3)
unfolding T'_def a0_def a0'_def abs_apply_terms_def
by blast
show ?B
using B step_props(2,4) admissible_transaction_Value_vars[OF bspec[OF P T]]
by (auto simp add: T'_def a0_def a0'_def abs_apply_terms_def)
qed
lemma reachable_constraints_covered:
assumes 𝒜_reach: "𝒜 ∈ reachable_constraints P"
and ℐ: "welltyped_constraint_model ℐ 𝒜"
and FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"ground (set FP)"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
and transactions_covered: "list_all (transaction_check FP OCC TI) P"
shows "∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
and "α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
using 𝒜_reach ℐ
proof (induction rule: reachable_constraints.induct)
case init
{ case 1 show ?case by (simp add: abs_intruder_knowledge_def) }
{ case 2 show ?case by (simp add: abs_value_constants_def) }
next
case (step 𝒜 T σ α)
{ case 1
hence "welltyped_constraint_model ℐ 𝒜"
by (metis welltyped_constraint_model_prefix)
hence IH: "∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
using step.IH by metis+
show ?case
using reachable_constraints_covered_step[
OF step.hyps(1,2) "1.prems" step.hyps(3,4) FP(1,2) IH(1)
FP(3) OCC IH(2) TI P transactions_covered]
by metis
}
{ case 2
hence "welltyped_constraint_model ℐ 𝒜"
by (metis welltyped_constraint_model_prefix)
hence IH: "∀t ∈ α⇩i⇩k 𝒜 ℐ. timpl_closure_set (set FP) (set TI) ⊢⇩c t"
"α⇩v⇩a⇩l⇩s 𝒜 ℐ ⊆ absc ` set OCC"
using step.IH by metis+
show ?case
using reachable_constraints_covered_step[
OF step.hyps(1,2) "2.prems" step.hyps(3,4) FP(1,2) IH(1)
FP(3) OCC IH(2) TI P transactions_covered]
by metis
}
qed
lemma attack_in_fixpoint_if_attack_in_ik:
fixes FP::"('fun,'atom,'sets) prot_terms"
assumes "∀t ∈ IK ⋅⇩α⇩s⇩e⇩t a. FP ⊢⇩c t"
and "attack⟨n⟩ ∈ IK"
shows "attack⟨n⟩ ∈ FP"
proof -
have "attack⟨n⟩ ⋅⇩α a ∈ IK ⋅⇩α⇩s⇩e⇩t a" by (rule abs_in[OF assms(2)])
hence "FP ⊢⇩c attack⟨n⟩ ⋅⇩α a" using assms(1) by blast
moreover have "attack⟨n⟩ ⋅⇩α a = attack⟨n⟩" by simp
ultimately have "FP ⊢⇩c attack⟨n⟩" by metis
thus ?thesis using ideduct_synth_priv_const_in_ik[of FP "Attack n"] by simp
qed
lemma attack_in_fixpoint_if_attack_in_timpl_closure_set:
fixes FP::"('fun,'atom,'sets) prot_terms"
assumes "attack⟨n⟩ ∈ timpl_closure_set FP TI"
shows "attack⟨n⟩ ∈ FP"
proof -
have "∀f ∈ funs_term (attack⟨n⟩). ¬is_Abs f" by auto
thus ?thesis using timpl_closure_set_no_Abs_in_set[OF assms] by blast
qed
theorem prot_secure_if_fixpoint_covered_typed:
assumes FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"ground (set FP)"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and P:
"∀T ∈ set P. admissible_transaction T"
and transactions_covered: "list_all (transaction_check FP OCC TI) P"
and attack_notin_FP: "attack⟨n⟩ ∉ set FP"
and 𝒜: "𝒜 ∈ reachable_constraints P"
shows "∄ℐ. welltyped_constraint_model ℐ (𝒜@[(l, send⟨attack⟨n⟩⟩)])" (is "∄ℐ. ?P ℐ")
proof
assume "∃ℐ. ?P ℐ"
then obtain ℐ where ℐ: "welltyped_constraint_model ℐ (𝒜@[(l, send⟨attack⟨n⟩⟩)])"
by moura
hence ℐ': "constr_sem_stateful ℐ (unlabel (𝒜@[(l, send⟨attack⟨n⟩⟩)]))"
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)" "wt⇩s⇩u⇩b⇩s⇩t ℐ"
unfolding welltyped_constraint_model_def constraint_model_def by metis+
have 0: "attack⟨n⟩ ∉ ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ"
using welltyped_constraint_model_prefix[OF ℐ]
reachable_constraints_covered(1)[OF 𝒜 _ FP OCC TI P transactions_covered]
attack_in_fixpoint_if_attack_in_ik[
of "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ" "α⇩0 (db⇩l⇩s⇩s⇩t 𝒜 ℐ)" "timpl_closure_set (set FP) (set TI)" n]
attack_in_fixpoint_if_attack_in_timpl_closure_set
attack_notin_FP
unfolding abs_intruder_knowledge_def by blast
have 1: "ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ ⊢ attack⟨n⟩"
using ℐ strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" _ ℐ]
unfolding welltyped_constraint_model_def constraint_model_def by force
have 2: "wf⇩t⇩r⇩m⇩s (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ)"
using reachable_constraints_wf⇩t⇩r⇩m⇩s[OF _ 𝒜] admissible_transactions_wf⇩t⇩r⇩m⇩s P(1)
ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset[of "unlabel 𝒜"] wf_trms_subst[OF ℐ'(3)]
by fast
have 3: "∀x ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜). ¬TAtom AttackType ⊑ Γ⇩v x"
using reachable_constraints_vars_TAtom_typed[OF 𝒜 P(1)]
fv_ik_subset_vars_sst'[of "unlabel 𝒜"]
by fastforce
have 4: "attack⟨n⟩ ∉ set (snd (Ana t)) ⋅⇩s⇩e⇩t ℐ" when t: "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)" for t
proof
assume "attack⟨n⟩ ∈ set (snd (Ana t)) ⋅⇩s⇩e⇩t ℐ"
then obtain s where s: "s ∈ set (snd (Ana t))" "s ⋅ ℐ = attack⟨n⟩" by moura
obtain x where x: "s = Var x"
by (cases s) (use s reachable_constraints_no_Ana_Attack[OF 𝒜 P(1) t] in auto)
have "x ∈ fv t" using x Ana_subterm'[OF s(1)] vars_iff_subtermeq by force
hence "x ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)" using t fv_subterms by fastforce
hence "Γ⇩v x ≠ TAtom AttackType" using 3 by fastforce
thus False using s(2) x wt_subst_trm''[OF ℐ'(4), of "Var x"] by fastforce
qed
have 5: "attack⟨n⟩ ∉ set (snd (Ana t))" when t: "t ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ)" for t
proof
assume "attack⟨n⟩ ∈ set (snd (Ana t))"
then obtain s where s:
"s ∈ subterms⇩s⇩e⇩t (ℐ ` fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜))" "attack⟨n⟩ ∈ set (snd (Ana s))"
using Ana_subst_subterms_cases[OF t] 4 by fast
then obtain x where x: "x ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜)" "s ⊑ ℐ x" by moura
hence "ℐ x ∈ subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t 𝒜 ⋅⇩s⇩e⇩t ℐ)"
using var_is_subterm[of x] subterms_subst_subset'[of ℐ "ik⇩l⇩s⇩s⇩t 𝒜"]
by force
hence *: "wf⇩t⇩r⇩m (ℐ x)" "wf⇩t⇩r⇩m s"
using wf_trms_subterms[OF 2] wf_trm_subtermeq[OF _ x(2)]
by auto
show False
using term.order_trans[
OF subtermeq_imp_subtermtypeeq[OF *(2) Ana_subterm'[OF s(2)]]
subtermeq_imp_subtermtypeeq[OF *(1) x(2)]]
3 x(1) wt_subst_trm''[OF ℐ'(4), of "Var x"]
by force
qed
show False
using 0 private_const_deduct[OF _ 1] 5
by simp
qed
end
subsection ‹Theorem: A Protocol is Secure if it is Covered by a Fixed-Point›
context stateful_protocol_model
begin
theorem prot_secure_if_fixpoint_covered:
fixes P
assumes FP:
"analyzed (timpl_closure_set (set FP) (set TI))"
"wf⇩t⇩r⇩m⇩s (set FP)"
"ground (set FP)"
and OCC:
"∀t ∈ timpl_closure_set (set FP) (set TI). ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
"timpl_closure_set (absc ` set OCC) (set TI) ⊆ absc ` set OCC"
and TI:
"set TI = {(a,b) ∈ (set TI)⇧+. a ≠ b}"
and M:
"has_all_wt_instances_of Γ (⋃T ∈ set P. trms_transaction T) N"
"finite N"
"tfr⇩s⇩e⇩t N"
"wf⇩t⇩r⇩m⇩s N"
and P:
"∀T ∈ set P. admissible_transaction T"
"∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
and transactions_covered: "list_all (transaction_check FP OCC TI) P"
and attack_notin_FP: "attack⟨n⟩ ∉ set FP"
and A: "𝒜 ∈ reachable_constraints P"
shows "∄ℐ. constraint_model ℐ (𝒜@[(l, send⟨attack⟨n⟩⟩)])"
(is "∄ℐ. ?P 𝒜 ℐ")
proof
assume "∃ℐ. ?P 𝒜 ℐ"
then obtain ℐ where I:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
"constr_sem_stateful ℐ (unlabel (𝒜@[(l, send⟨attack⟨n⟩⟩)]))"
unfolding constraint_model_def by moura
let ?n = "[(l, send⟨attack⟨n⟩⟩)]"
let ?A = "𝒜@?n"
have "∀T ∈ set P. wellformed_transaction T"
"∀T ∈ set P. admissible_transaction_terms T"
using P(1) unfolding admissible_transaction_def by blast+
moreover have "∀T ∈ set P. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
using P(1) unfolding admissible_transaction_def admissible_transaction_terms_def by blast
ultimately have 0: "wf⇩s⇩s⇩t (unlabel 𝒜)" "tfr⇩s⇩s⇩t (unlabel 𝒜)" "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
using reachable_constraints_tfr[OF _ M P A] reachable_constraints_wf[OF _ _ A] by metis+
have 1: "wf⇩s⇩s⇩t (unlabel ?A)" "tfr⇩s⇩s⇩t (unlabel ?A)" "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t ?A)"
proof -
show "wf⇩s⇩s⇩t (unlabel ?A)"
using 0(1) wf⇩s⇩s⇩t_append_suffix'[of "{}" "unlabel 𝒜" "unlabel ?n"] unlabel_append[of 𝒜 ?n]
by simp
show "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t ?A)"
using 0(3) trms⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel ?n"] unlabel_append[of 𝒜 ?n]
by fastforce
have "∀t ∈ trms⇩l⇩s⇩s⇩t ?n ∪ pair ` setops⇩s⇩s⇩t (unlabel ?n). ∃c. t = Fun c []"
"∀t ∈ trms⇩l⇩s⇩s⇩t ?n ∪ pair ` setops⇩s⇩s⇩t (unlabel ?n). Ana t = ([],[])"
by (simp_all add: setops⇩s⇩s⇩t_def)
hence "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜 ∪ pair ` setops⇩s⇩s⇩t (unlabel 𝒜) ∪
(trms⇩l⇩s⇩s⇩t ?n ∪ pair ` setops⇩s⇩s⇩t (unlabel ?n)))"
using 0(2) tfr_consts_mono unfolding tfr⇩s⇩s⇩t_def by blast
hence "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (𝒜@?n) ∪ pair ` setops⇩s⇩s⇩t (unlabel (𝒜@?n)))"
using unlabel_append[of 𝒜 ?n] trms⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel ?n"]
setops⇩s⇩s⇩t_append[of "unlabel 𝒜" "unlabel ?n"]
by (simp add: setops⇩s⇩s⇩t_def)
thus "tfr⇩s⇩s⇩t (unlabel ?A)"
using 0(2) unlabel_append[of ?A ?n]
unfolding tfr⇩s⇩s⇩t_def by auto
qed
obtain ℐ⇩τ where I':
"welltyped_constraint_model ℐ⇩τ ?A"
using stateful_typing_result[OF 1 I(1,3)]
by (metis welltyped_constraint_model_def constraint_model_def)
note a = FP OCC TI P(1) transactions_covered attack_notin_FP A
show False
using prot_secure_if_fixpoint_covered_typed[OF a] I'
by force
qed
end
subsection ‹Automatic Fixed-Point Computation›
context stateful_protocol_model
begin
definition compute_fixpoint_fun' where
"compute_fixpoint_fun' P (n::nat option) enable_traces S0 ≡
let sy = intruder_synth_mod_timpls;
FP' = λS. fst (fst S);
TI' = λS. snd (fst S);
OCC' = λS. remdups (
(map (λt. the_Abs (the_Fun (args t ! 1)))
(filter (λt. is_Fun t ∧ the_Fun t = OccursFact) (FP' S)))@
(map snd (TI' S)));
equal_states = λS S'. set (FP' S) = set (FP' S') ∧ set (TI' S) = set (TI' S');
trace' = λS. snd S;
close = λM f. let g = remdups ∘ f in while (λA. set (g A) ≠ set A) g M;
close' = λM f. let g = remdups ∘ f in while (λA. set (g A) ≠ set A) g M;
trancl_minus_refl = λTI.
let aux = λts p. map (λq. (fst p,snd q)) (filter ((=) (snd p) ∘ fst) ts)
in filter (λp. fst p ≠ snd p) (close' TI (λts. concat (map (aux ts) ts)@ts));
snd_Ana = λN M TI. let N' = filter (λt. ∀k ∈ set (fst (Ana t)). sy M TI k) N in
filter (λt. ¬sy M TI t)
(concat (map (λt. filter (λs. s ∈ set (snd (Ana t))) (args t)) N'));
Ana_cl = λFP TI.
close FP (λM. (M@snd_Ana M M TI));
TI_cl = λFP TI.
close FP (λM. (M@filter (λt. ¬sy M TI t)
(concat (map (λm. concat (map (λ(a,b). ⟨a --» b⟩⟨m⟩) TI)) M))));
Ana_cl' = λFP TI.
let N = λM. comp_timpl_closure_list (filter (λt. ∃k∈set (fst (Ana t)). ¬sy M TI k) M) TI
in close FP (λM. M@snd_Ana (N M) M TI);
Δ = λS. transaction_check_comp (FP' S) (OCC' S) (TI' S);
result = λS T δ.
let not_fresh = λx. x ∉ set (transaction_fresh T);
xs = filter not_fresh (fv_list⇩s⇩s⇩t (unlabel (transaction_strand T)));
u = λδ x. absdbupd (unlabel (transaction_strand T)) x (δ x)
in (remdups (filter (λt. ¬sy (FP' S) (TI' S) t)
(map (λt. the_msg t ⋅ (absc ∘ u δ))
(filter is_Send (unlabel (transaction_send T))))),
remdups (filter (λs. fst s ≠ snd s) (map (λx. (δ x, u δ x)) xs)));
update_state = λS. if list_ex (λt. is_Fun t ∧ is_Attack (the_Fun t)) (FP' S) then S
else let results = map (λT. map (λδ. result S T (abs_substs_fun δ)) (Δ S T)) P;
newtrace_flt = (λn. let x = results ! n; y = map fst x; z = map snd x
in set (concat y) - set (FP' S) ≠ {} ∨ set (concat z) - set (TI' S) ≠ {});
trace =
if enable_traces
then trace' S@[filter newtrace_flt [0..<length results]]
else [];
U = concat results;
V = ((remdups (concat (map fst U)@FP' S),
remdups (filter (λx. fst x ≠ snd x) (concat (map snd U)@TI' S))),
trace);
W = ((Ana_cl (TI_cl (FP' V) (TI' V)) (TI' V),
trancl_minus_refl (TI' V)),
trace' V)
in if ¬equal_states W S then W
else ((Ana_cl' (FP' W) (TI' W), TI' W), trace' W);
S = ((λh. case n of None ⇒ while (λS. ¬equal_states S (h S)) h | Some m ⇒ h ^^ m)
update_state S0)
in ((FP' S, OCC' S, TI' S), trace' S)"
definition compute_fixpoint_fun where
"compute_fixpoint_fun P ≡ fst (compute_fixpoint_fun' P None False (([],[]),[]))"
end
subsection ‹Locales for Protocols Proven Secure through Fixed-Point Coverage›
type_synonym ('f,'a,'s) fixpoint_triple =
"('f,'a,'s) prot_term list × 's set list × ('s set × 's set) list"
context stateful_protocol_model
begin
definition "attack_notin_fixpoint (FPT::('fun,'atom,'sets) fixpoint_triple) ≡
list_all (λt. ∀f ∈ funs_term t. ¬is_Attack f) (fst FPT)"
definition "protocol_covered_by_fixpoint (FPT::('fun,'atom,'sets) fixpoint_triple) P ≡
let (FP, OCC, TI) = FPT
in list_all (transaction_check FP OCC TI) P"
definition "analyzed_fixpoint (FPT::('fun,'atom,'sets) fixpoint_triple) ≡
let (FP, _, TI) = FPT
in analyzed_closed_mod_timpls FP TI"
definition "wellformed_protocol' (P::('fun,'atom,'sets,'lbl) prot) N ≡
list_all admissible_transaction P ∧
has_all_wt_instances_of Γ (⋃T ∈ set P. trms_transaction T) (set N) ∧
comp_tfr⇩s⇩e⇩t arity Ana Γ N ∧
list_all (λT. list_all (comp_tfr⇩s⇩s⇩t⇩p Γ Pair) (unlabel (transaction_strand T))) P"
definition "wellformed_protocol (P::('fun,'atom,'sets,'lbl) prot) ≡
let f = λM. remdups (concat (map subterms_list M@map (fst ∘ Ana) M));
N0 = remdups (concat (map (trms_list⇩s⇩s⇩t ∘ unlabel ∘ transaction_strand) P));
N = while (λA. set (f A) ≠ set A) f N0
in wellformed_protocol' P N"
definition "wellformed_fixpoint (FPT::('fun,'atom,'sets) fixpoint_triple) ≡
let (FP, OCC, TI) = FPT; OCC' = set OCC
in list_all (λt. wf⇩t⇩r⇩m' arity t ∧ fv t = {}) FP ∧
list_all (λa. a ∈ OCC') (map snd TI) ∧
list_all (λ(a,b). list_all (λ(c,d). b = c ∧ a ≠ d ⟶ List.member TI (a,d)) TI) TI ∧
list_all (λp. fst p ≠ snd p) TI ∧
list_all (λt. ∀f ∈ funs_term t. is_Abs f ⟶ the_Abs f ∈ OCC') FP"
lemma protocol_covered_by_fixpoint_I1[intro]:
assumes "list_all (protocol_covered_by_fixpoint FPT) P"
shows "protocol_covered_by_fixpoint FPT (concat P)"
using assms by (auto simp add: protocol_covered_by_fixpoint_def list_all_iff)
lemma protocol_covered_by_fixpoint_I2[intro]:
assumes "protocol_covered_by_fixpoint FPT P1"
and "protocol_covered_by_fixpoint FPT P2"
shows "protocol_covered_by_fixpoint FPT (P1@P2)"
using assms by (auto simp add: protocol_covered_by_fixpoint_def)
lemma protocol_covered_by_fixpoint_I3[intro]:
assumes "∀T ∈ set P. ∀δ::('fun,'atom,'sets) prot_var ⇒ 'sets set.
transaction_check_pre FP TI T δ ⟶ transaction_check_post FP TI T δ"
shows "protocol_covered_by_fixpoint (FP,OCC,TI) P"
using assms
unfolding protocol_covered_by_fixpoint_def transaction_check_def transaction_check_comp_def
list_all_iff Let_def case_prod_unfold Product_Type.fst_conv Product_Type.snd_conv
by fastforce
lemmas protocol_covered_by_fixpoint_intros =
protocol_covered_by_fixpoint_I1
protocol_covered_by_fixpoint_I2
protocol_covered_by_fixpoint_I3
lemma prot_secure_if_prot_checks:
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
and FP_OCC_TI:: "('fun, 'atom, 'sets) fixpoint_triple"
assumes attack_notin_fixpoint: "attack_notin_fixpoint FP_OCC_TI"
and transactions_covered: "protocol_covered_by_fixpoint FP_OCC_TI P"
and analyzed_fixpoint: "analyzed_fixpoint FP_OCC_TI"
and wellformed_protocol: "wellformed_protocol' P N"
and wellformed_fixpoint: "wellformed_fixpoint FP_OCC_TI"
shows "∀𝒜 ∈ reachable_constraints P. ∄ℐ. constraint_model ℐ (𝒜@[(l, send⟨attack⟨n⟩⟩)])"
proof -
define FP where "FP ≡ let (FP,_,_) = FP_OCC_TI in FP"
define OCC where "OCC ≡ let (_,OCC,_) = FP_OCC_TI in OCC"
define TI where "TI ≡ let (_,_,TI) = FP_OCC_TI in TI"
have attack_notin_FP: "attack⟨n⟩ ∉ set FP"
using attack_notin_fixpoint[unfolded attack_notin_fixpoint_def]
unfolding list_all_iff FP_def by force
have 1: "∀(a,b) ∈ set TI. ∀(c,d) ∈ set TI. b = c ∧ a ≠ d ⟶ (a,d) ∈ set TI"
using wellformed_fixpoint
unfolding wellformed_fixpoint_def wf⇩t⇩r⇩m⇩s_code[symmetric] Let_def TI_def
list_all_iff member_def case_prod_unfold
by auto
have 0: "wf⇩t⇩r⇩m⇩s (set FP)"
and 2: "∀(a,b) ∈ set TI. a ≠ b"
and 3: "snd ` set TI ⊆ set OCC"
and 4: "∀t ∈ set FP. ∀f ∈ funs_term t. is_Abs f ⟶ f ∈ Abs ` set OCC"
and 5: "ground (set FP)"
using wellformed_fixpoint
unfolding wellformed_fixpoint_def wf⇩t⇩r⇩m_code[symmetric] is_Abs_def the_Abs_def
list_all_iff Let_def case_prod_unfold set_map FP_def OCC_def TI_def
by (fast, fast, blast, fastforce, simp)
have 8: "finite (set N)"
and 9: "has_all_wt_instances_of Γ (⋃T ∈ set P. trms_transaction T) (set N)"
and 10: "tfr⇩s⇩e⇩t (set N)"
and 11: "∀T ∈ set P. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
and 12: "∀T ∈ set P. admissible_transaction T"
using wellformed_protocol tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t[of N]
unfolding Let_def list_all_iff wellformed_protocol_def wellformed_protocol'_def
wf⇩t⇩r⇩m⇩s_code[symmetric] tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p[symmetric]
by fast+
have 13: "wf⇩t⇩r⇩m⇩s (set N)"
using wellformed_protocol
unfolding wellformed_protocol_def wellformed_protocol'_def
wf⇩t⇩r⇩m_code[symmetric] comp_tfr⇩s⇩e⇩t_def list_all_iff
finite_SMP_representation_def
by blast
note TI0 = trancl_eqI'[OF 1 2]
have "analyzed (timpl_closure_set (set FP) (set TI))"
using analyzed_fixpoint[unfolded analyzed_fixpoint_def]
analyzed_closed_mod_timpls_is_analyzed_timpl_closure_set[OF TI0 0]
unfolding FP_def TI_def
by force
note FP0 = this 0 5
note OCC0 = funs_term_OCC_TI_subset(1)[OF 4 3]
timpl_closure_set_supset'[OF funs_term_OCC_TI_subset(2)[OF 4 3]]
note M0 = 9 8 10 13
have "list_all (transaction_check FP OCC TI) P"
using transactions_covered[unfolded protocol_covered_by_fixpoint_def]
unfolding FP_def OCC_def TI_def
by force
note P0 = 12 11 this attack_notin_FP
show ?thesis by (metis prot_secure_if_fixpoint_covered[OF FP0 OCC0 TI0 M0 P0])
qed
end
locale secure_stateful_protocol =
pm: stateful_protocol_model arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2
for arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
+
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
and FP_OCC_TI:: "('fun, 'atom, 'sets) fixpoint_triple"
and P_SMP::"('fun, 'atom, 'sets) prot_term list"
assumes attack_notin_fixpoint: "pm.attack_notin_fixpoint FP_OCC_TI"
and transactions_covered: "pm.protocol_covered_by_fixpoint FP_OCC_TI P"
and analyzed_fixpoint: "pm.analyzed_fixpoint FP_OCC_TI"
and wellformed_protocol: "pm.wellformed_protocol' P P_SMP"
and wellformed_fixpoint: "pm.wellformed_fixpoint FP_OCC_TI"
begin
theorem protocol_secure:
"∀𝒜 ∈ pm.reachable_constraints P. ∄ℐ. pm.constraint_model ℐ (𝒜@[(l, send⟨attack⟨n⟩⟩)])"
by (rule pm.prot_secure_if_prot_checks[OF
attack_notin_fixpoint transactions_covered
analyzed_fixpoint wellformed_protocol wellformed_fixpoint])
end
locale secure_stateful_protocol' =
pm: stateful_protocol_model arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2
for arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
+
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
and FP_OCC_TI:: "('fun, 'atom, 'sets) fixpoint_triple"
assumes attack_notin_fixpoint': "pm.attack_notin_fixpoint FP_OCC_TI"
and transactions_covered': "pm.protocol_covered_by_fixpoint FP_OCC_TI P"
and analyzed_fixpoint': "pm.analyzed_fixpoint FP_OCC_TI"
and wellformed_protocol': "pm.wellformed_protocol P"
and wellformed_fixpoint': "pm.wellformed_fixpoint FP_OCC_TI"
begin
sublocale secure_stateful_protocol
arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2 P
FP_OCC_TI
"let f = λM. remdups (concat (map subterms_list M@map (fst ∘ pm.Ana) M));
N0 = remdups (concat (map (trms_list⇩s⇩s⇩t ∘ unlabel ∘ transaction_strand) P))
in while (λA. set (f A) ≠ set A) f N0"
apply unfold_locales
using attack_notin_fixpoint' transactions_covered' analyzed_fixpoint'
wellformed_protocol'[unfolded pm.wellformed_protocol_def Let_def] wellformed_fixpoint'
unfolding Let_def by blast+
end
locale secure_stateful_protocol'' =
pm: stateful_protocol_model arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2
for arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
+
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
assumes checks: "let FPT = pm.compute_fixpoint_fun P
in pm.attack_notin_fixpoint FPT ∧ pm.protocol_covered_by_fixpoint FPT P ∧
pm.analyzed_fixpoint FPT ∧ pm.wellformed_protocol P ∧ pm.wellformed_fixpoint FPT"
begin
sublocale secure_stateful_protocol'
arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2 P "pm.compute_fixpoint_fun P"
using checks[unfolded Let_def case_prod_unfold] by unfold_locales meson+
end
locale secure_stateful_protocol''' =
pm: stateful_protocol_model arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2
for arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
+
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
and FP_OCC_TI:: "('fun, 'atom, 'sets) fixpoint_triple"
and P_SMP::"('fun, 'atom, 'sets) prot_term list"
assumes checks': "let P' = P; FPT = FP_OCC_TI; P'_SMP = P_SMP
in pm.attack_notin_fixpoint FPT ∧
pm.protocol_covered_by_fixpoint FPT P' ∧
pm.analyzed_fixpoint FPT ∧
pm.wellformed_protocol' P' P'_SMP ∧
pm.wellformed_fixpoint FPT"
begin
sublocale secure_stateful_protocol
arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2 P FP_OCC_TI P_SMP
using checks'[unfolded Let_def case_prod_unfold] by unfold_locales meson+
end
locale secure_stateful_protocol'''' =
pm: stateful_protocol_model arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2
for arity⇩f::"'fun ⇒ nat"
and arity⇩s::"'sets ⇒ nat"
and public⇩f::"'fun ⇒ bool"
and Ana⇩f::"'fun ⇒ ((('fun,'atom::finite,'sets) prot_fun, nat) term list × nat list)"
and Γ⇩f::"'fun ⇒ 'atom option"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
+
fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
and FP_OCC_TI:: "('fun, 'atom, 'sets) fixpoint_triple"
assumes checks'': "let P' = P; FPT = FP_OCC_TI
in pm.attack_notin_fixpoint FPT ∧
pm.protocol_covered_by_fixpoint FPT P' ∧
pm.analyzed_fixpoint FPT ∧
pm.wellformed_protocol P' ∧
pm.wellformed_fixpoint FPT"
begin
sublocale secure_stateful_protocol'
arity⇩f arity⇩s public⇩f Ana⇩f Γ⇩f label_witness1 label_witness2 P FP_OCC_TI
using checks''[unfolded Let_def case_prod_unfold] by unfold_locales meson+
end
subsection ‹Automatic Protocol Composition›
context stateful_protocol_model
begin
definition wellformed_composable_protocols where
"wellformed_composable_protocols (P::('fun,'atom,'sets,'lbl) prot list) N ≡
let
Ts = concat P;
steps = concat (map transaction_strand Ts);
MP0 = ⋃T ∈ set Ts. trms_transaction T ∪ pair' Pair ` setops_transaction T
in
list_all (wf⇩t⇩r⇩m' arity) N ∧
has_all_wt_instances_of Γ MP0 (set N) ∧
comp_tfr⇩s⇩e⇩t arity Ana Γ N ∧
list_all (comp_tfr⇩s⇩s⇩t⇩p Γ Pair ∘ snd) steps ∧
list_all (λT. wellformed_transaction T) Ts ∧
list_all (λT. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)) Ts ∧
list_all (λT. list_all (λx. Γ⇩v x = TAtom Value) (transaction_fresh T)) Ts"
definition composable_protocols where
"composable_protocols (P::('fun,'atom,'sets,'lbl) prot list) Ms S ≡
let
Ts = concat P;
steps = concat (map transaction_strand Ts);
MP0 = ⋃T ∈ set Ts. trms_transaction T ∪ pair' Pair ` setops_transaction T;
M_fun = (λl. case find ((=) l ∘ fst) Ms of Some M ⇒ snd M | None ⇒ [])
in comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair steps M_fun S"
lemma composable_protocols_par_comp_constr:
fixes S f
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "Sec ≡ (f (set S)) - {m. intruder_synth {} m}"
assumes Ps_pc: "wellformed_composable_protocols Ps N" "composable_protocols Ps Ms S"
shows "∀𝒜 ∈ reachable_constraints (concat Ps). ∀ℐ. constraint_model ℐ 𝒜 ⟶
(∃ℐ⇩τ. welltyped_constraint_model ℐ⇩τ 𝒜 ∧
((∀n. welltyped_constraint_model ℐ⇩τ (proj n 𝒜)) ∨
(∃𝒜'. prefix 𝒜' 𝒜 ∧ strand_leaks⇩l⇩s⇩s⇩t 𝒜' Sec ℐ⇩τ)))"
(is "∀𝒜 ∈ _. ∀_. _ ⟶ ?Q 𝒜 ℐ")
proof (intro allI ballI impI)
fix 𝒜 ℐ
assume 𝒜: "𝒜 ∈ reachable_constraints (concat Ps)" and ℐ: "constraint_model ℐ 𝒜"
let ?Ts = "concat Ps"
let ?steps = "concat (map transaction_strand ?Ts)"
let ?MP0 = "⋃T ∈ set ?Ts. trms_transaction T ∪ pair' Pair ` setops_transaction T"
let ?M_fun = "λl. case find ((=) l ∘ fst) Ms of Some M ⇒ snd M | None ⇒ []"
have M:
"has_all_wt_instances_of Γ ?MP0 (set N)"
"finite (set N)" "tfr⇩s⇩e⇩t (set N)" "wf⇩t⇩r⇩m⇩s (set N)"
using Ps_pc tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t[of N]
unfolding composable_protocols_def wellformed_composable_protocols_def
Let_def list_all_iff wf⇩t⇩r⇩m_code[symmetric]
by fast+
have P:
"∀T ∈ set ?Ts. wellformed_transaction T"
"∀T ∈ set ?Ts. wf⇩t⇩r⇩m⇩s' arity (trms_transaction T)"
"∀T ∈ set ?Ts. ∀x ∈ set (transaction_fresh T). Γ⇩v x = TAtom Value"
"∀T ∈ set ?Ts. list_all tfr⇩s⇩s⇩t⇩p (unlabel (transaction_strand T))"
"comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair ?steps ?M_fun S"
using Ps_pc tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p
unfolding wellformed_composable_protocols_def composable_protocols_def
Let_def list_all_iff unlabel_def wf⇩t⇩r⇩m⇩s_code[symmetric]
by (meson, meson, meson, fastforce, blast)
show "?Q 𝒜 ℐ"
using reachable_constraints_par_comp_constr[OF M P 𝒜 ℐ]
unfolding Sec_def f_def by fast
qed
end
end
Theory Eisbach_Protocol_Verification
section ‹Useful Eisbach Methods for Automating Protocol Verification›
theory Eisbach_Protocol_Verification
imports Main "HOL-Eisbach.Eisbach_Tools"
begin
named_theorems exhausts
named_theorems type_class_instance_lemmata
named_theorems protocol_checks
named_theorems coverage_check_unfold_protocol_lemma
named_theorems coverage_check_unfold_lemmata
named_theorems coverage_check_intro_lemmata
named_theorems transaction_coverage_lemmata
method UNIV_lemma =
(rule UNIV_eq_I; (subst insert_iff)+; subst empty_iff; smt exhausts)+
method type_class_instance =
(intro_classes; auto simp add: type_class_instance_lemmata)
method protocol_model_subgoal =
(((rule allI, case_tac f); (erule forw_subst)+)?; simp_all)
method protocol_model_interpretation =
(unfold_locales; protocol_model_subgoal+)
method check_protocol_intro =
(unfold_locales, unfold protocol_checks[symmetric])
method check_protocol_with methods meth =
(check_protocol_intro, meth)
method check_protocol' =
(check_protocol_with ‹code_simp+›)
method check_protocol_unsafe' =
(check_protocol_with ‹eval+›)
method check_protocol =
(check_protocol_with ‹
code_simp,
code_simp,
code_simp,
code_simp,
code_simp›)
method check_protocol_unsafe =
(check_protocol_with ‹
eval,
eval,
eval,
eval,
eval›)
method coverage_check_intro =
(((unfold coverage_check_unfold_protocol_lemma)?;
intro coverage_check_intro_lemmata;
simp only: list_all_simps list_all_append list.map concat.simps map_append product_concat_map;
intro conjI TrueI);
(clarsimp+)?;
((rule transaction_coverage_lemmata)+)?)
method coverage_check_unfold =
(unfold coverage_check_unfold_protocol_lemma coverage_check_unfold_lemmata
list_all_iff Let_def case_prod_unfold Product_Type.fst_conv Product_Type.snd_conv)
end
Theory ml_yacc_lib
section‹ML Yacc Library›
theory
"ml_yacc_lib"
imports
Main
begin
ML_file "ml-yacc-lib/base.sig"
ML_file "ml-yacc-lib/join.sml"
ML_file "ml-yacc-lib/lrtable.sml"
ML_file "ml-yacc-lib/stream.sml"
ML_file "ml-yacc-lib/parser2.sml"
end
File ‹ml-yacc-lib/base.sig›
signature STREAM =
sig type 'xa stream
val streamify : (unit -> '_a) -> '_a stream
val cons : '_a * '_a stream -> '_a stream
val get : '_a stream -> '_a * '_a stream
end
signature LR_TABLE =
sig
datatype ('a,'b) pairlist = EMPTY | PAIR of 'a * 'b * ('a,'b) pairlist
datatype state = STATE of int
datatype term = T of int
datatype nonterm = NT of int
datatype action = SHIFT of state
| REDUCE of int
| ACCEPT
| ERROR
type table
val numStates : table -> int
val numRules : table -> int
val describeActions : table -> state ->
(term,action) pairlist * action
val describeGoto : table -> state -> (nonterm,state) pairlist
val action : table -> state * term -> action
val goto : table -> state * nonterm -> state
val initialState : table -> state
exception Goto of state * nonterm
val mkLrTable : {actions : ((term,action) pairlist * action) array,
gotos : (nonterm,state) pairlist array,
numStates : int, numRules : int,
initialState : state} -> table
end
signature TOKEN =
sig
structure LrTable : LR_TABLE
datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b)
val sameToken : ('a,'b) token * ('a,'b) token -> bool
end
signature LR_PARSER =
sig
structure Stream: STREAM
structure LrTable : LR_TABLE
structure Token : TOKEN
sharing LrTable = Token.LrTable
exception ParseError
val parse : {table : LrTable.table,
lexer : ('_b,'_c) Token.token Stream.stream,
arg: 'arg,
saction : int *
'_c *
(LrTable.state * ('_b * '_c * '_c)) list *
'arg ->
LrTable.nonterm *
('_b * '_c * '_c) *
((LrTable.state *('_b * '_c * '_c)) list),
void : '_b,
ec : { is_keyword : LrTable.term -> bool,
noShift : LrTable.term -> bool,
preferred_change : (LrTable.term list * LrTable.term list) list,
errtermvalue : LrTable.term -> '_b,
showTerminal : LrTable.term -> string,
terms: LrTable.term list,
error : string * '_c * '_c -> unit
},
lookahead : int
} -> '_b *
(('_b,'_c) Token.token Stream.stream)
end
signature LEXER =
sig
structure UserDeclarations :
sig
type ('a,'b) token
type pos
type svalue
end
val makeLexer : (int -> string) -> unit ->
(UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token
end
signature ARG_LEXER =
sig
structure UserDeclarations :
sig
type ('a,'b) token
type pos
type svalue
type arg
end
val makeLexer : (int -> string) -> UserDeclarations.arg -> unit ->
(UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token
end
signature PARSER_DATA =
sig
type pos
type svalue
type arg
type result
structure LrTable : LR_TABLE
structure Token : TOKEN
sharing Token.LrTable = LrTable
structure Actions :
sig
val actions : int * pos *
(LrTable.state * (svalue * pos * pos)) list * arg->
LrTable.nonterm * (svalue * pos * pos) *
((LrTable.state *(svalue * pos * pos)) list)
val void : svalue
val extract : svalue -> result
end
structure EC :
sig
val is_keyword : LrTable.term -> bool
val noShift : LrTable.term -> bool
val preferred_change : (LrTable.term list * LrTable.term list) list
val errtermvalue : LrTable.term -> svalue
val showTerminal : LrTable.term -> string
val terms: LrTable.term list
end
val table : LrTable.table
end
signature PARSER =
sig
structure Token : TOKEN
structure Stream : STREAM
exception ParseError
type pos
type result
type arg
type svalue
val makeLexer : (int -> string) ->
(svalue,pos) Token.token Stream.stream
val parse : int * ((svalue,pos) Token.token Stream.stream) *
(string * pos * pos -> unit) * arg ->
result * (svalue,pos) Token.token Stream.stream
val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token ->
bool
end
signature ARG_PARSER =
sig
structure Token : TOKEN
structure Stream : STREAM
exception ParseError
type arg
type lexarg
type pos
type result
type svalue
val makeLexer : (int -> string) -> lexarg ->
(svalue,pos) Token.token Stream.stream
val parse : int * ((svalue,pos) Token.token Stream.stream) *
(string * pos * pos -> unit) * arg ->
result * (svalue,pos) Token.token Stream.stream
val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token ->
bool
end
File ‹ml-yacc-lib/join.sml›
functor Join(structure Lex : LEXER
structure ParserData: PARSER_DATA
structure LrParser : LR_PARSER
sharing ParserData.LrTable = LrParser.LrTable
sharing ParserData.Token = LrParser.Token
sharing type Lex.UserDeclarations.svalue = ParserData.svalue
sharing type Lex.UserDeclarations.pos = ParserData.pos
sharing type Lex.UserDeclarations.token = ParserData.Token.token)
: PARSER =
struct
structure Token = ParserData.Token
structure Stream = LrParser.Stream
exception ParseError = LrParser.ParseError
type arg = ParserData.arg
type pos = ParserData.pos
type result = ParserData.result
type svalue = ParserData.svalue
val makeLexer = LrParser.Stream.streamify o Lex.makeLexer
val parse = fn (lookahead,lexer,error,arg) =>
(fn (a,b) => (ParserData.Actions.extract a,b))
(LrParser.parse {table = ParserData.table,
lexer=lexer,
lookahead=lookahead,
saction = ParserData.Actions.actions,
arg=arg,
void= ParserData.Actions.void,
ec = {is_keyword = ParserData.EC.is_keyword,
noShift = ParserData.EC.noShift,
preferred_change = ParserData.EC.preferred_change,
errtermvalue = ParserData.EC.errtermvalue,
error=error,
showTerminal = ParserData.EC.showTerminal,
terms = ParserData.EC.terms}}
)
val sameToken = Token.sameToken
end
functor JoinWithArg(structure Lex : ARG_LEXER
structure ParserData: PARSER_DATA
structure LrParser : LR_PARSER
sharing ParserData.LrTable = LrParser.LrTable
sharing ParserData.Token = LrParser.Token
sharing type Lex.UserDeclarations.svalue = ParserData.svalue
sharing type Lex.UserDeclarations.pos = ParserData.pos
sharing type Lex.UserDeclarations.token = ParserData.Token.token)
: ARG_PARSER =
struct
structure Token = ParserData.Token
structure Stream = LrParser.Stream
exception ParseError = LrParser.ParseError
type arg = ParserData.arg
type lexarg = Lex.UserDeclarations.arg
type pos = ParserData.pos
type result = ParserData.result
type svalue = ParserData.svalue
val makeLexer = fn s => fn arg =>
LrParser.Stream.streamify (Lex.makeLexer s arg)
val parse = fn (lookahead,lexer,error,arg) =>
(fn (a,b) => (ParserData.Actions.extract a,b))
(LrParser.parse {table = ParserData.table,
lexer=lexer,
lookahead=lookahead,
saction = ParserData.Actions.actions,
arg=arg,
void= ParserData.Actions.void,
ec = {is_keyword = ParserData.EC.is_keyword,
noShift = ParserData.EC.noShift,
preferred_change = ParserData.EC.preferred_change,
errtermvalue = ParserData.EC.errtermvalue,
error=error,
showTerminal = ParserData.EC.showTerminal,
terms = ParserData.EC.terms}}
)
val sameToken = Token.sameToken
end;
File ‹ml-yacc-lib/lrtable.sml›
structure LrTable : LR_TABLE =
struct
open Array List
infix 9 sub
datatype ('a,'b) pairlist = EMPTY
| PAIR of 'a * 'b * ('a,'b) pairlist
datatype term = T of int
datatype nonterm = NT of int
datatype state = STATE of int
datatype action = SHIFT of state
| REDUCE of int
| ACCEPT
| ERROR
exception Goto of state * nonterm
type table = {states: int, rules : int,initialState: state,
action: ((term,action) pairlist * action) array,
goto : (nonterm,state) pairlist array}
val numStates = fn ({states,...} : table) => states
val numRules = fn ({rules,...} : table) => rules
val describeActions =
fn ({action,...} : table) =>
fn (STATE s) => action sub s
val describeGoto =
fn ({goto,...} : table) =>
fn (STATE s) => goto sub s
fun findTerm (T term,row,default) =
let fun find (PAIR (T key,data,r)) =
if key < term then find r
else if key=term then data
else default
| find EMPTY = default
in find row
end
fun findNonterm (NT nt,row) =
let fun find (PAIR (NT key,data,r)) =
if key < nt then find r
else if key=nt then SOME data
else NONE
| find EMPTY = NONE
in find row
end
val action = fn ({action,...} : table) =>
fn (STATE state,term) =>
let val (row,default) = action sub state
in findTerm(term,row,default)
end
val goto = fn ({goto,...} : table) =>
fn (a as (STATE state,nonterm)) =>
case findNonterm(nonterm,goto sub state)
of SOME state => state
| NONE => raise (Goto a)
val initialState = fn ({initialState,...} : table) => initialState
val mkLrTable = fn {actions,gotos,initialState,numStates,numRules} =>
({action=actions,goto=gotos,
states=numStates,
rules=numRules,
initialState=initialState} : table)
end;
File ‹ml-yacc-lib/stream.sml›
structure Stream :> STREAM =
struct
datatype 'a str = EVAL of 'a * 'a str Unsynchronized.ref | UNEVAL of (unit->'a)
type 'a stream = 'a str Unsynchronized.ref
fun get(Unsynchronized.ref(EVAL t)) = t
| get(s as Unsynchronized.ref(UNEVAL f)) =
let val t = (f(), Unsynchronized.ref(UNEVAL f)) in s := EVAL t; t end
fun streamify f = Unsynchronized.ref(UNEVAL f)
fun cons(a,s) = Unsynchronized.ref(EVAL(a,s))
end;
File ‹ml-yacc-lib/parser2.sml›
signature FIFO =
sig type 'a queue
val empty : 'a queue
exception Empty
val get : 'a queue -> 'a * 'a queue
val put : 'a * 'a queue -> 'a queue
end
structure LrParser :> LR_PARSER =
struct
structure LrTable = LrTable
structure Stream = Stream
val print = warning
fun eqT (LrTable.T i, LrTable.T i') = i = i'
structure Token : TOKEN =
struct
structure LrTable = LrTable
datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b)
val sameToken = fn (TOKEN(t,_),TOKEN(t',_)) => eqT (t,t')
end
open LrTable
open Token
val DEBUG1 = false
val DEBUG2 = false
exception ParseError
exception ParseImpossible of int
structure Fifo :> FIFO =
struct
type 'a queue = ('a list * 'a list)
val empty = (nil,nil)
exception Empty
fun get(a::x, y) = (a, (x,y))
| get(nil, nil) = raise Empty
| get(nil, y) = get(rev y, nil)
fun put(a,(x,y)) = (x,a::y)
end
type ('a,'b) elem = (state * ('a * 'b * 'b))
type ('a,'b) stack = ('a,'b) elem list
type ('a,'b) lexv = ('a,'b) token
type ('a,'b) lexpair = ('a,'b) lexv * (('a,'b) lexv Stream.stream)
type ('a,'b) distanceParse =
('a,'b) lexpair *
('a,'b) stack *
(('a,'b) stack * ('a,'b) lexpair) Fifo.queue *
int ->
('a,'b) lexpair *
('a,'b) stack *
(('a,'b) stack * ('a,'b) lexpair) Fifo.queue *
int *
action option
type ('a,'b) ecRecord =
{is_keyword : term -> bool,
preferred_change : (term list * term list) list,
error : string * 'b * 'b -> unit,
errtermvalue : term -> 'a,
terms : term list,
showTerminal : term -> string,
noShift : term -> bool}
local
val print = warning
val println = fn s => (print s; print "\n")
val showState = fn (STATE s) => "STATE " ^ (Int.toString s)
in
fun printStack(stack: ('a,'b) stack, n: int) =
case stack
of (state,_) :: rest =>
(print("\t" ^ Int.toString n ^ ": ");
println(showState state);
printStack(rest, n+1))
| nil => ()
fun prAction showTerminal
(stack as (state,_) :: _, next as (TOKEN (term,_),_), action) =
(println "Parse: state stack:";
printStack(stack, 0);
print(" state="
^ showState state
^ " next="
^ showTerminal term
^ " action="
);
case action
of SHIFT state => println ("SHIFT " ^ (showState state))
| REDUCE i => println ("REDUCE " ^ (Int.toString i))
| ERROR => println "ERROR"
| ACCEPT => println "ACCEPT")
| prAction _ (_,_,action) = ()
end
val ssParse =
fn (table,showTerminal,saction,fixError,arg) =>
let val prAction = prAction showTerminal
val action = LrTable.action table
val goto = LrTable.goto table
fun parseStep(args as
(lexPair as (TOKEN (terminal, value as (_,leftPos,_)),
lexer
),
stack as (state,_) :: _,
queue)) =
let val nextAction = action (state,terminal)
val _ = if DEBUG1 then prAction(stack,lexPair,nextAction)
else ()
in case nextAction
of SHIFT s =>
let val newStack = (s,value) :: stack
val newLexPair = Stream.get lexer
val (_,newQueue) =Fifo.get(Fifo.put((newStack,newLexPair),
queue))
in parseStep(newLexPair,(s,value)::stack,newQueue)
end
| REDUCE i =>
(case saction(i,leftPos,stack,arg)
of (nonterm,value,stack as (state,_) :: _) =>
parseStep(lexPair,(goto(state,nonterm),value)::stack,
queue)
| _ => raise (ParseImpossible 197))
| ERROR => parseStep(fixError args)
| ACCEPT =>
(case stack
of (_,(topvalue,_,_)) :: _ =>
let val (token,restLexer) = lexPair
in (topvalue,Stream.cons(token,restLexer))
end
| _ => raise (ParseImpossible 202))
end
| parseStep _ = raise (ParseImpossible 204)
in parseStep
end
val distanceParse =
fn (table,showTerminal,saction,arg) =>
let val prAction = prAction showTerminal
val action = LrTable.action table
val goto = LrTable.goto table
fun parseStep(lexPair,stack,queue,0) = (lexPair,stack,queue,0,NONE)
| parseStep(lexPair as (TOKEN (terminal, value as (_,leftPos,_)),
lexer
),
stack as (state,_) :: _,
queue,distance) =
let val nextAction = action(state,terminal)
val _ = if DEBUG1 then prAction(stack,lexPair,nextAction)
else ()
in case nextAction
of SHIFT s =>
let val newStack = (s,value) :: stack
val newLexPair = Stream.get lexer
in parseStep(newLexPair,(s,value)::stack,
Fifo.put((newStack,newLexPair),queue),distance-1)
end
| REDUCE i =>
(case saction(i,leftPos,stack,arg)
of (nonterm,value,stack as (state,_) :: _) =>
parseStep(lexPair,(goto(state,nonterm),value)::stack,
queue,distance)
| _ => raise (ParseImpossible 240))
| ERROR => (lexPair,stack,queue,distance,SOME nextAction)
| ACCEPT => (lexPair,stack,queue,distance,SOME nextAction)
end
| parseStep _ = raise (ParseImpossible 242)
in parseStep : ('_a,'_b) distanceParse
end
fun mkFixError({is_keyword,terms,errtermvalue,
preferred_change,noShift,
showTerminal,error,...} : ('_a,'_b) ecRecord,
distanceParse : ('_a,'_b) distanceParse,
minAdvance,maxAdvance)
(lexv as (TOKEN (term,value as (_,leftPos,_)),_),stack,queue) =
let val _ = if DEBUG2 then
error("syntax error found at " ^ (showTerminal term),
leftPos,leftPos)
else ()
fun tokAt(t,p) = TOKEN(t,(errtermvalue t,p,p))
val minDelta = 3
val stateList =
let fun f q = let val (elem,newQueue) = Fifo.get q
in elem :: (f newQueue)
end handle Fifo.Empty => nil
in f queue
end
val (_, numStateList) =
List.foldr (fn (a,(num,r)) => (num+1,(a,num)::r)) (0, []) stateList
datatype ('a,'b) change = CHANGE of
{pos : int, distance : int, leftPos: 'b, rightPos: 'b,
new : ('a,'b) lexv list, orig : ('a,'b) lexv list}
val showTerms = String.concat o map (fn TOKEN(t,_) => " " ^ showTerminal t)
val printChange = fn c =>
let val CHANGE {distance,new,orig,pos,...} = c
in (print ("{distance= " ^ (Int.toString distance));
print (",orig ="); print(showTerms orig);
print (",new ="); print(showTerms new);
print (",pos= " ^ (Int.toString pos));
print "}\n")
end
val printChangeList = app printChange
fun parse (lexPair,stack,queuePos : int) =
case distanceParse(lexPair,stack,Fifo.empty,queuePos+maxAdvance+1)
of (_,_,_,distance,SOME ACCEPT) =>
if maxAdvance-distance-1 >= 0
then maxAdvance
else maxAdvance-distance-1
| (_,_,_,distance,_) => maxAdvance - distance - 1
fun catList l f = List.foldr (fn(a,r)=> f a @ r) [] l
fun keywordsDelta new = if List.exists (fn(TOKEN(t,_))=>is_keyword t) new
then minDelta else 0
fun tryChange{lex,stack,pos,leftPos,rightPos,orig,new} =
let val lex' = List.foldr (fn (t',p)=>(t',Stream.cons p)) lex new
val distance = parse(lex',stack,pos+length new-length orig)
in if distance >= minAdvance + keywordsDelta new
then [CHANGE{pos=pos,leftPos=leftPos,rightPos=rightPos,
distance=distance,orig=orig,new=new}]
else []
end
fun tryDelete n ((stack,lexPair as (TOKEN(term,(_,l,r)),_)),qPos) =
let fun del(0,accum,left,right,lexPair) =
tryChange{lex=lexPair,stack=stack,
pos=qPos,leftPos=left,rightPos=right,
orig=rev accum, new=[]}
| del(n,accum,left,right,(tok as TOKEN(term,(_,_,r)),lexer)) =
if noShift term then []
else del(n-1,tok::accum,left,r,Stream.get lexer)
in del(n,[],l,r,lexPair)
end
fun tryInsert((stack,lexPair as (TOKEN(_,(_,l,_)),_)),queuePos) =
catList terms (fn t =>
tryChange{lex=lexPair,stack=stack,
pos=queuePos,orig=[],new=[tokAt(t,l)],
leftPos=l,rightPos=l})
fun trySubst ((stack,lexPair as (orig as TOKEN (term,(_,l,r)),lexer)),
queuePos) =
if noShift term then []
else
catList terms (fn t =>
tryChange{lex=Stream.get lexer,stack=stack,
pos=queuePos,
leftPos=l,rightPos=r,orig=[orig],
new=[tokAt(t,r)]})
fun do_delete(nil,lp as (TOKEN(_,(_,l,_)),_)) = SOME(nil,l,l,lp)
| do_delete([t],(tok as TOKEN(t',(_,l,r)),lp')) =
if eqT (t, t')
then SOME([tok],l,r,Stream.get lp')
else NONE
| do_delete(t::rest,(tok as TOKEN(t',(_,l,r)),lp')) =
if eqT (t,t')
then case do_delete(rest,Stream.get lp')
of SOME(deleted,l',r',lp'') =>
SOME(tok::deleted,l,r',lp'')
| NONE => NONE
else NONE
fun tryPreferred((stack,lexPair),queuePos) =
catList preferred_change (fn (delete,insert) =>
if List.exists noShift delete then []
else case do_delete(delete,lexPair)
of SOME(deleted,l,r,lp) =>
tryChange{lex=lp,stack=stack,pos=queuePos,
leftPos=l,rightPos=r,orig=deleted,
new=map (fn t=>(tokAt(t,r))) insert}
| NONE => [])
val changes = catList numStateList tryPreferred @
catList numStateList tryInsert @
catList numStateList trySubst @
catList numStateList (tryDelete 1) @
catList numStateList (tryDelete 2) @
catList numStateList (tryDelete 3)
val findMaxDist = fn l =>
List.foldr (fn (CHANGE {distance,...},high) => Int.max(distance,high)) 0 l
val maxDist = findMaxDist changes
val changes = catList changes
(fn(c as CHANGE{distance,...}) =>
if distance=maxDist then [c] else [])
in case changes
of (l as change :: _) =>
let fun print_msg (CHANGE {new,orig,leftPos,rightPos,...}) =
let val s =
case (orig,new)
of (_::_,[]) => "deleting " ^ (showTerms orig)
| ([],_::_) => "inserting " ^ (showTerms new)
| _ => "replacing " ^ (showTerms orig) ^
" with " ^ (showTerms new)
in error ("syntax error: " ^ s,leftPos,rightPos)
end
val _ =
(if length l > 1 andalso DEBUG2 then
(print "multiple fixes possible; could fix it by:\n";
app print_msg l;
print "chosen correction:\n")
else ();
print_msg change)
val findNth = fn n =>
let fun f (h::t,0) = (h,rev t)
| f (h::t,n) = f(t,n-1)
| f (nil,_) = let exception FindNth
in raise FindNth
end
in f (rev stateList,n)
end
val CHANGE {pos,orig,new,...} = change
val (last,queueFront) = findNth pos
val (stack,lexPair) = last
val lp1 = List.foldl(fn (_,(_,r)) => Stream.get r) lexPair orig
val lp2 = List.foldr(fn(t,r)=>(t,Stream.cons r)) lp1 new
val restQueue =
Fifo.put((stack,lp2),
List.foldl Fifo.put Fifo.empty queueFront)
val (lexPair,stack,queue,_,_) =
distanceParse(lp2,stack,restQueue,pos)
in (lexPair,stack,queue)
end
| nil => (error("syntax error found at " ^ (showTerminal term),
leftPos,leftPos); raise ParseError)
end
val parse = fn {arg,table,lexer,saction,void,lookahead,
ec=ec as {showTerminal,...} : ('_a,'_b) ecRecord} =>
let val distance = 15
val minAdvance = 1
val maxAdvance = Int.max(lookahead,0)
val lexPair = Stream.get lexer
val (TOKEN (_,(_,leftPos,_)),_) = lexPair
val startStack = [(initialState table,(void,leftPos,leftPos))]
val startQueue = Fifo.put((startStack,lexPair),Fifo.empty)
val distanceParse = distanceParse(table,showTerminal,saction,arg)
val fixError = mkFixError(ec,distanceParse,minAdvance,maxAdvance)
val ssParse = ssParse(table,showTerminal,saction,fixError,arg)
fun loop (lexPair,stack,queue,_,SOME ACCEPT) =
ssParse(lexPair,stack,queue)
| loop (lexPair,stack,queue,0,_) = ssParse(lexPair,stack,queue)
| loop (lexPair,stack,queue,distance,SOME ERROR) =
let val (lexPair,stack,queue) = fixError(lexPair,stack,queue)
in loop (distanceParse(lexPair,stack,queue,distance))
end
| loop _ = let exception ParseInternal
in raise ParseInternal
end
in loop (distanceParse(lexPair,startStack,startQueue,distance))
end
end;
Theory trac_term
section ‹Abstract Syntax for Trac Terms›
theory
trac_term
imports
"First_Order_Terms.Term"
"ml_yacc_lib"
begin
datatype cMsg = cVar "string * string"
| cConst string
| cFun "string * cMsg list"
ML‹
structure Trac_Utils =
struct
fun list_find p ts =
let
fun aux _ [] = NONE
| aux n (t::ts) =
if p t
then SOME (t,n)
else aux (n+1) ts
in
aux 0 ts
end
fun map_prod f (a,b) = (f a, f b)
fun list_product [] = [[]]
| list_product (xs::xss) =
List.concat (map (fn x => map (fn ys => x::ys) (list_product xss)) xs)
fun list_toString elem_toString xs =
let
fun aux [] = ""
| aux [x] = elem_toString x
| aux (x::y::xs) = elem_toString x ^ ", " ^ aux (y::xs)
in
"[" ^ aux xs ^ "]"
end
val list_to_str = list_toString (fn x => x)
fun list_triangle_product _ [] = []
| list_triangle_product f (x::xs) = map (f x) xs@list_triangle_product f xs
fun list_subseqs [] = [[]]
| list_subseqs (x::xs) = let val xss = list_subseqs xs in map (cons x) xss@xss end
fun list_intersect xs ys =
List.exists (fn x => member (op =) ys x) xs orelse
List.exists (fn y => member (op =) xs y) ys
fun list_partitions xs constrs =
let
val peq = eq_set (op =)
val pseq = eq_set peq
val psseq = eq_set pseq
fun illegal p q =
let
val pq = union (op =) p q
fun f (a,b) = member (op =) pq a andalso member (op =) pq b
in
List.exists f constrs
end
fun merges _ [] = []
| merges q (p::ps) =
if illegal p q then map (cons p) (merges q ps)
else (union (op =) p q::ps)::(map (cons p) (merges q ps))
fun merges_all [] = []
| merges_all (p::ps) = merges p ps@map (cons p) (merges_all ps)
fun step pss = fold (union pseq) (map merges_all pss) []
fun loop pss pssprev =
let val pss' = step pss
in if psseq (pss,pss') then pssprev else loop pss' (union pseq pss' pssprev)
end
val init = [map single xs]
in
loop init init
end
fun mk_unique [] = []
| mk_unique (x::xs) = x::mk_unique(List.filter (fn y => y <> x) xs)
fun list_rm_pair sel l x = filter (fn e => sel e <> x) l
fun list_minus list_rm l m = List.foldl (fn (a,b) => list_rm b a) l m
fun list_upto n =
let
fun aux m = if m >= n then [] else m::aux (m+1)
in
aux 0
end
end
›
ML‹
structure Trac_Term =
struct
open Trac_Utils
exception TypeError
type TypeDecl = string * string
datatype Msg = Var of string
| Const of string
| Fun of string * Msg list
| Attack
datatype VarType = EnumType of string
| ValueType
| Untyped
datatype cMsg = cVar of string * VarType
| cConst of string
| cFun of string * cMsg list
| cAttack
| cSet of string * cMsg list
| cAbs of (string * string list) list
| cOccursFact of cMsg
| cPrivFunSec
| cEnum of string
fun type_of et vt n =
case List.find (fn (v,_) => v = n) et of
SOME (_,t) => EnumType t
| NONE =>
if List.exists (fn v => v = n) vt
then ValueType
else Untyped
fun certifyMsg et vt (Var n) = cVar (n, type_of et vt n)
| certifyMsg _ _ (Const c) = cConst c
| certifyMsg et vt (Fun (f, ts)) = cFun (f, map (certifyMsg et vt) ts)
| certifyMsg _ _ Attack = cAttack
fun mk_Value_cVar x = cVar (x,ValueType)
val fv_Msg =
let
fun aux (Var x) = [x]
| aux (Fun (_,ts)) = List.concat (map aux ts)
| aux _ = []
in
mk_unique o aux
end
val fv_cMsg =
let
fun aux (cVar x) = [x]
| aux (cFun (_,ts)) = List.concat (map aux ts)
| aux (cSet (_,ts)) = List.concat (map aux ts)
| aux (cOccursFact bs) = aux bs
| aux _ = []
in
mk_unique o aux
end
fun subst_apply' (delta:(string * VarType) -> cMsg) (t:cMsg) =
case t of
cVar x => delta x
| cFun (f,ts) => cFun (f, map (subst_apply' delta) ts)
| cSet (s,ts) => cSet (s, map (subst_apply' delta) ts)
| cOccursFact bs => cOccursFact (subst_apply' delta bs)
| c => c
fun subst_apply (delta:(string * cMsg) list) =
subst_apply' (fn (n,tau) => (
case List.find (fn x => fst x = n) delta of
SOME x => snd x
| NONE => cVar (n,tau)))
end
›
ML‹
structure TracProtocol =
struct
open Trac_Utils
datatype type_spec_elem =
Consts of string list
| Union of string list
fun is_Consts t = case t of Consts _ => true | _ => false
fun the_Consts t = case t of Consts cs => cs | _ => error "Consts"
type type_spec = (string * type_spec_elem) list
type set_spec = (string * string)
fun extract_Consts (tspec:type_spec) =
(List.concat o map the_Consts o filter is_Consts o map snd) tspec
type funT = (string * string)
type fun_spec = {private: funT list, public: funT list}
type ruleT = (string * string list) * Trac_Term.Msg list * string list
type anaT = ruleT list
datatype prot_label = LabelN | LabelS
datatype action = RECEIVE of Trac_Term.Msg
| SEND of Trac_Term.Msg
| IN of Trac_Term.Msg * (string * Trac_Term.Msg list)
| NOTIN of Trac_Term.Msg * (string * Trac_Term.Msg list)
| NOTINANY of Trac_Term.Msg * string
| INSERT of Trac_Term.Msg * (string * Trac_Term.Msg list)
| DELETE of Trac_Term.Msg * (string * Trac_Term.Msg list)
| NEW of string
| ATTACK
datatype cAction = cReceive of Trac_Term.cMsg
| cSend of Trac_Term.cMsg
| cInequality of Trac_Term.cMsg * Trac_Term.cMsg
| cInSet of Trac_Term.cMsg * Trac_Term.cMsg
| cNotInSet of Trac_Term.cMsg * Trac_Term.cMsg
| cNotInAny of Trac_Term.cMsg * string
| cInsert of Trac_Term.cMsg * Trac_Term.cMsg
| cDelete of Trac_Term.cMsg * Trac_Term.cMsg
| cNew of string
| cAssertAttack
type transaction_name = string * (string * string) list * (string * string) list
type transaction={transaction:transaction_name,actions:(prot_label * action) list}
type cTransaction={
transaction:transaction_name,
receive_actions:(prot_label * cAction) list,
checksingle_actions:(prot_label * cAction) list,
checkall_actions:(prot_label * cAction) list,
fresh_actions:(prot_label * cAction) list,
update_actions:(prot_label * cAction) list,
send_actions:(prot_label * cAction) list,
attack_actions:(prot_label * cAction) list}
fun mkTransaction transaction actions = {transaction=transaction,
actions=actions}:transaction
fun is_RECEIVE a = case a of RECEIVE _ => true | _ => false
fun is_SEND a = case a of SEND _ => true | _ => false
fun is_IN a = case a of IN _ => true | _ => false
fun is_NOTIN a = case a of NOTIN _ => true | _ => false
fun is_NOTINANY a = case a of NOTINANY _ => true | _ => false
fun is_INSERT a = case a of INSERT _ => true | _ => false
fun is_DELETE a = case a of DELETE _ => true | _ => false
fun is_NEW a = case a of NEW _ => true | _ => false
fun is_ATTACK a = case a of ATTACK => true | _ => false
fun the_RECEIVE a = case a of RECEIVE t => t | _ => error "RECEIVE"
fun the_SEND a = case a of SEND t => t | _ => error "SEND"
fun the_IN a = case a of IN t => t | _ => error "IN"
fun the_NOTIN a = case a of NOTIN t => t | _ => error "NOTIN"
fun the_NOTINANY a = case a of NOTINANY t => t | _ => error "NOTINANY"
fun the_INSERT a = case a of INSERT t => t | _ => error "INSERT"
fun the_DELETE a = case a of DELETE t => t | _ => error "DELETE"
fun the_NEW a = case a of NEW t => t | _ => error "FRESH"
fun maybe_the_RECEIVE a = case a of RECEIVE t => SOME t | _ => NONE
fun maybe_the_SEND a = case a of SEND t => SOME t | _ => NONE
fun maybe_the_IN a = case a of IN t => SOME t | _ => NONE
fun maybe_the_NOTIN a = case a of NOTIN t => SOME t | _ => NONE
fun maybe_the_NOTINANY a = case a of NOTINANY t => SOME t | _ => NONE
fun maybe_the_INSERT a = case a of INSERT t => SOME t | _ => NONE
fun maybe_the_DELETE a = case a of DELETE t => SOME t | _ => NONE
fun maybe_the_NEW a = case a of NEW t => SOME t | _ => NONE
fun is_Receive a = case a of cReceive _ => true | _ => false
fun is_Send a = case a of cSend _ => true | _ => false
fun is_Inequality a = case a of cInequality _ => true | _ => false
fun is_InSet a = case a of cInSet _ => true | _ => false
fun is_NotInSet a = case a of cNotInSet _ => true | _ => false
fun is_NotInAny a = case a of cNotInAny _ => true | _ => false
fun is_Insert a = case a of cInsert _ => true | _ => false
fun is_Delete a = case a of cDelete _ => true | _ => false
fun is_Fresh a = case a of cNew _ => true | _ => false
fun is_Attack a = case a of cAssertAttack => true | _ => false
fun the_Receive a = case a of cReceive t => t | _ => error "Receive"
fun the_Send a = case a of cSend t => t | _ => error "Send"
fun the_Inequality a = case a of cInequality t => t | _ => error "Inequality"
fun the_InSet a = case a of cInSet t => t | _ => error "InSet"
fun the_NotInSet a = case a of cNotInSet t => t | _ => error "NotInSet"
fun the_NotInAny a = case a of cNotInAny t => t | _ => error "NotInAny"
fun the_Insert a = case a of cInsert t => t | _ => error "Insert"
fun the_Delete a = case a of cDelete t => t | _ => error "Delete"
fun the_Fresh a = case a of cNew t => t | _ => error "New"
fun maybe_the_Receive a = case a of cReceive t => SOME t | _ => NONE
fun maybe_the_Send a = case a of cSend t => SOME t | _ => NONE
fun maybe_the_Inequality a = case a of cInequality t => SOME t | _ => NONE
fun maybe_the_InSet a = case a of cInSet t => SOME t | _ => NONE
fun maybe_the_NotInSet a = case a of cNotInSet t => SOME t | _ => NONE
fun maybe_the_NotInAny a = case a of cNotInAny t => SOME t | _ => NONE
fun maybe_the_Insert a = case a of cInsert t => SOME t | _ => NONE
fun maybe_the_Delete a = case a of cDelete t => SOME t | _ => NONE
fun maybe_the_Fresh a = case a of cNew t => SOME t | _ => NONE
fun certifyAction et vt (lbl,SEND t) = (lbl,cSend (Trac_Term.certifyMsg et vt t))
| certifyAction et vt (lbl,RECEIVE t) = (lbl,cReceive (Trac_Term.certifyMsg et vt t))
| certifyAction et vt (lbl,IN (x,(s,ps))) = (lbl,cInSet
(Trac_Term.certifyMsg et vt x, Trac_Term.cSet (s, map (Trac_Term.certifyMsg et vt) ps)))
| certifyAction et vt (lbl,NOTIN (x,(s,ps))) = (lbl,cNotInSet
(Trac_Term.certifyMsg et vt x, Trac_Term.cSet (s, map (Trac_Term.certifyMsg et vt) ps)))
| certifyAction et vt (lbl,NOTINANY (x,s)) = (lbl,cNotInAny (Trac_Term.certifyMsg et vt x, s))
| certifyAction et vt (lbl,INSERT (x,(s,ps))) = (lbl,cInsert
(Trac_Term.certifyMsg et vt x, Trac_Term.cSet (s, map (Trac_Term.certifyMsg et vt) ps)))
| certifyAction et vt (lbl,DELETE (x,(s,ps))) = (lbl,cDelete
(Trac_Term.certifyMsg et vt x, Trac_Term.cSet (s, map (Trac_Term.certifyMsg et vt) ps)))
| certifyAction _ _ (lbl,NEW x) = (lbl,cNew x)
| certifyAction _ _ (lbl,ATTACK) = (lbl,cAssertAttack)
fun certifyTransaction (tr:transaction) =
let
val mk_cOccurs = Trac_Term.cOccursFact
fun mk_Value_cVar x = Trac_Term.cVar (x,Trac_Term.ValueType)
fun mk_cInequality x y = cInequality (mk_Value_cVar x, mk_Value_cVar y)
val mk_cInequalities = list_triangle_product mk_cInequality
val fresh_vals = map_filter (maybe_the_NEW o snd) (#actions tr)
val decl_vars = map fst (#2 (#transaction tr))
val neq_constrs = #3 (#transaction tr)
val _ = if List.exists (fn x => List.exists (fn y => x = y) fresh_vals) decl_vars
orelse List.exists (fn x => List.exists (fn y => x = y) decl_vars) fresh_vals
then error "the fresh and the declared variables must not overlap"
else ()
val _ = case List.find (fn (x,y) => x = y) neq_constrs of
SOME (x,y) => error ("illegal inequality constraint: " ^ x ^ " != " ^ y)
| NONE => ()
val nonfresh_vals = map fst (filter (fn x => snd x = "value") (#2 (#transaction tr)))
val enum_vars = filter (fn x => snd x <> "value") (#2 (#transaction tr))
fun lblS t = (LabelS,t)
val cactions = map (certifyAction enum_vars (nonfresh_vals@fresh_vals)) (#actions tr)
val nonfresh_occurs = map (lblS o cReceive o mk_cOccurs o mk_Value_cVar) nonfresh_vals
val receives = filter (is_Receive o snd) cactions
val value_inequalities = map lblS (mk_cInequalities nonfresh_vals)
val checksingles = filter (fn (_,a) => is_InSet a orelse is_NotInSet a) cactions
val checkalls = filter (is_NotInAny o snd) cactions
val updates = filter (fn (_,a) => is_Insert a orelse is_Delete a) cactions
val fresh = filter (is_Fresh o snd) cactions
val sends = filter (is_Send o snd) cactions
val fresh_occurs = map (lblS o cSend o mk_cOccurs o mk_Value_cVar) fresh_vals
val attack_signals = filter (is_Attack o snd) cactions
in
{transaction = #transaction tr,
receive_actions = nonfresh_occurs@receives,
checksingle_actions = value_inequalities@checksingles,
checkall_actions = checkalls,
fresh_actions = fresh,
update_actions = updates,
send_actions = sends@fresh_occurs,
attack_actions = attack_signals}:cTransaction
end
fun subst_apply_action (delta:(string * Trac_Term.cMsg) list) (lbl:prot_label,a:cAction) =
let
val apply = Trac_Term.subst_apply delta
in
case a of
cReceive t => (lbl,cReceive (apply t))
| cSend t => (lbl,cSend (apply t))
| cInequality (x,y) => (lbl,cInequality (apply x, apply y))
| cInSet (x,s) => (lbl,cInSet (apply x, apply s))
| cNotInSet (x,s) => (lbl,cNotInSet (apply x, apply s))
| cNotInAny (x,s) => (lbl,cNotInAny (apply x, s))
| cInsert (x,s) => (lbl,cInsert (apply x, apply s))
| cDelete (x,s) => (lbl,cDelete (apply x, apply s))
| cNew x => (lbl,cNew x)
| cAssertAttack => (lbl,cAssertAttack)
end
fun subst_apply_actions delta =
map (subst_apply_action delta)
type protocol = {
name:string
,type_spec:type_spec
,set_spec:set_spec list
,function_spec:fun_spec option
,analysis_spec:anaT
,transaction_spec:(string option * transaction list) list
,fixed_point: (Trac_Term.cMsg list * (string * string list) list list *
((string * string list) list * (string * string list) list) list) option
}
exception TypeError
val fun_empty = {
public=[]
,private=[]
}:fun_spec
fun update_fun_public (fun_spec:fun_spec) public =
({public = public
,private = #private fun_spec
}):fun_spec
fun update_fun_private (fun_spec:fun_spec) private =
({public = #public fun_spec
,private = private
}):fun_spec
val empty={
name=""
,type_spec=[]
,set_spec=[]
,function_spec=NONE
,analysis_spec=[]
,transaction_spec=[]
,fixed_point = NONE
}:protocol
fun update_name (protocol_spec:protocol) name =
({name = name
,type_spec = #type_spec protocol_spec
,set_spec = #set_spec protocol_spec
,function_spec = #function_spec protocol_spec
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_sets (protocol_spec:protocol) set_spec =
({name = #name protocol_spec
,type_spec = #type_spec protocol_spec
,set_spec =
if has_duplicates (op =) (map fst set_spec)
then error "Multiple declarations of the same set family"
else set_spec
,function_spec = #function_spec protocol_spec
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_type_spec (protocol_spec:protocol) type_spec =
({name = #name protocol_spec
,type_spec =
if has_duplicates (op =) (map fst type_spec)
then error "Multiple declarations of the same enumeration type"
else type_spec
,set_spec = #set_spec protocol_spec
,function_spec = #function_spec protocol_spec
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_functions (protocol_spec:protocol) function_spec =
({name = #name protocol_spec
,type_spec = #type_spec protocol_spec
,set_spec = #set_spec protocol_spec
,function_spec = case function_spec of
SOME fs =>
if has_duplicates (op =) (map fst ((#public fs)@(#private fs)))
then error "Multiple declarations of the same constant or function symbol"
else SOME fs
| NONE => NONE
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_analysis (protocol_spec:protocol) analysis_spec =
({name = #name protocol_spec
,type_spec = #type_spec protocol_spec
,set_spec = #set_spec protocol_spec
,function_spec = #function_spec protocol_spec
,analysis_spec =
if has_duplicates (op =) (map (#1 o #1) analysis_spec)
then error "Multiple analysis rules declared for the same function symbol"
else if List.exists (has_duplicates (op =)) (map (#2 o #1) analysis_spec)
then error "The heads of the analysis rules must be linear terms"
else if let fun f ((_,xs),ts,ys) =
subset (op =) (ys@List.concat (map Trac_Term.fv_Msg ts), xs)
in List.exists (not o f) analysis_spec end
then error "Variables occurring in the body of an analysis rule should also occur in its head"
else analysis_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_transactions (prot_name:string option) (protocol_spec:protocol) transaction_spec =
({name = #name protocol_spec
,type_spec = #type_spec protocol_spec
,set_spec = #set_spec protocol_spec
,function_spec = #function_spec protocol_spec
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = (prot_name,transaction_spec)::(#transaction_spec protocol_spec)
,fixed_point = #fixed_point protocol_spec
}):protocol
fun update_fixed_point (protocol_spec:protocol) fixed_point =
({name = #name protocol_spec
,type_spec = #type_spec protocol_spec
,set_spec = #set_spec protocol_spec
,function_spec = #function_spec protocol_spec
,analysis_spec = #analysis_spec protocol_spec
,transaction_spec = #transaction_spec protocol_spec
,fixed_point = fixed_point
}):protocol
end
›
end
Theory trac_fp_parser
section‹Parser for Trac FP definitions›
theory
trac_fp_parser
imports
"trac_term"
begin
ML_file "trac_parser/trac_fp.grm.sig"
ML_file "trac_parser/trac_fp.lex.sml"
ML_file "trac_parser/trac_fp.grm.sml"
ML‹
structure TracFpParser : sig
val parse_file: string -> (Trac_Term.cMsg) list
val parse_str: string -> (Trac_Term.cMsg) list
val attack: Trac_Term.cMsg list -> bool
end =
struct
open Trac_Term
structure TracLrVals =
TracLrValsFun(structure Token = LrParser.Token)
structure TracLex =
TracLexFun(structure Tokens = TracLrVals.Tokens)
structure TracParser =
Join(structure LrParser = LrParser
structure ParserData = TracLrVals.ParserData
structure Lex = TracLex)
fun invoke lexstream =
let fun print_error (s,i:(int * int * int),_) =
TextIO.output(TextIO.stdOut,
"Error, line .... " ^ (Int.toString (#1 i)) ^"."^(Int.toString (#2 i ))^ ", " ^ s ^ "\n")
in TracParser.parse(0,lexstream,print_error,())
end
fun parse_fp lexer = let
val dummyEOF = TracLrVals.Tokens.EOF((0,0,0),(0,0,0))
fun certify (m,t) = Trac_Term.certifyMsg t [] m
fun loop lexer =
let
val _ = (TracLex.UserDeclarations.pos := (0,0,0);())
val (res,lexer) = invoke lexer
val (nextToken,lexer) = TracParser.Stream.get lexer
in if TracParser.sameToken(nextToken,dummyEOF) then ((),res)
else loop lexer
end
in map certify (#2(loop lexer))
end
fun parse_file tracFile = let
val infile = TextIO.openIn tracFile
val lexer = TracParser.makeLexer (fn _ => case ((TextIO.inputLine) infile) of
SOME s => s
| NONE => "")
in
parse_fp lexer
end
fun parse_str trac_fp_str = let
val parsed = Unsynchronized.ref false
fun input_string _ = if !parsed then "" else (parsed := true ;trac_fp_str)
val lexer = TracParser.makeLexer input_string
in
parse_fp lexer
end
fun attack fp = List.exists (fn e => e = cAttack) fp
end
›
end
File ‹trac_parser/trac_fp.grm.sig›
signature Trac_TOKENS =
sig
type ('a,'b) token
type svalue
val ATTACK: (string) * 'a * 'a -> (svalue,'a) token
val ZERO: (string) * 'a * 'a -> (svalue,'a) token
val ONE: (string) * 'a * 'a -> (svalue,'a) token
val INTEGER_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val LOWER_STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val UPPER_STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val DOUBLE_RARROW: (string) * 'a * 'a -> (svalue,'a) token
val DOUBLE_ASTERISK: (string) * 'a * 'a -> (svalue,'a) token
val ASTERISK: (string) * 'a * 'a -> (svalue,'a) token
val PAREN_CLOSE: (string) * 'a * 'a -> (svalue,'a) token
val PAREN_OPEN: (string) * 'a * 'a -> (svalue,'a) token
val COLON: (string) * 'a * 'a -> (svalue,'a) token
val WHERE: (string) * 'a * 'a -> (svalue,'a) token
val FIXEDPOINT: (string) * 'a * 'a -> (svalue,'a) token
val COMMA: (string) * 'a * 'a -> (svalue,'a) token
val EOF: 'a * 'a -> (svalue,'a) token
end
signature Trac_LRVALS=
sig
structure Tokens : Trac_TOKENS
structure ParserData:PARSER_DATA
sharing type ParserData.Token.token = Tokens.token
sharing type ParserData.svalue = Tokens.svalue
end
File ‹trac_parser/trac_fp.lex.sml›
functor TracLexFun(structure Tokens: Trac_TOKENS)=
struct
structure UserDeclarations =
struct
structure Tokens = Tokens
open Trac_Term
type pos = int * int * int
type svalue = Tokens.svalue
type ('a,'b) token = ('a,'b) Tokens.token
type lexresult= (svalue,pos) token
val pos = Unsynchronized.ref (0,0,0)
fun eof () = Tokens.EOF((!pos,!pos))
fun error (e,p : (int * int * int),_) = TextIO.output (TextIO.stdOut,
String.concat[
"line ", (Int.toString (#1 p)), "/",
(Int.toString (#2 p - #3 p)),": ", e, "\n"
])
fun inputPos yypos = ((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))),
(#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))))
fun inputPos_half yypos = (#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))
end
exception LexError
structure Internal =
struct
datatype yyfinstate = N of int
type statedata = {fin : yyfinstate list, trans: string}
val tab = let
val s = [
(0,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(1,
"\003\003\003\003\003\003\003\003\003\065\067\003\003\003\003\003\
\\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\
\\065\003\003\062\003\003\003\058\057\056\054\003\053\003\003\043\
\\041\041\041\041\041\041\041\041\041\041\040\003\003\038\003\003\
\\003\025\025\025\025\025\028\025\025\025\025\025\025\025\025\025\
\\025\025\025\025\025\025\025\025\025\025\025\003\003\003\003\003\
\\003\019\010\010\010\010\010\010\010\010\010\010\010\010\010\016\
\\010\010\010\010\010\010\010\011\010\010\004\003\003\003\003\003\
\\003"
),
(4,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\007\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(5,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(6,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(7,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\008\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(8,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\009\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(11,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\012\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(12,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\013\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(13,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\014\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(14,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\015\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(16,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\017\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(17,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\018\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(19,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\020\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(20,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\021\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(21,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\022\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(22,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\023\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(23,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\
\\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\000\
\\000\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\005\
\\000\005\005\005\005\005\005\005\005\005\005\024\005\005\005\005\
\\005\005\005\005\005\005\005\005\005\005\005\000\000\000\000\000\
\\000"
),
(25,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(27,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(28,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\029\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(29,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\030\026\026\000\000\000\000\000\
\\000"
),
(30,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\031\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(31,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\032\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(32,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\033\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(33,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\034\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(34,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\035\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(35,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\036\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(36,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\
\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\
\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\
\\026\026\026\026\037\026\026\026\026\026\026\000\000\000\000\000\
\\000"
),
(38,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\039\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(41,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\042\042\042\042\042\042\042\042\042\042\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(43,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\044\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(44,
"\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\046\045\045\045\045\052\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045"
),
(45,
"\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\046\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045"
),
(46,
"\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\050\047\047\047\047\049\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\047\
\\047"
),
(47,
"\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\046\045\045\045\045\048\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045"
),
(48,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\047\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(50,
"\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\046\045\045\045\045\051\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\045\
\\045"
),
(54,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\055\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(58,
"\000\000\000\000\000\000\000\000\000\059\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\059\000\000\000\000\000\000\061\000\000\000\000\000\060\060\060\
\\059\059\059\059\059\059\059\059\059\059\000\000\000\000\000\000\
\\000\059\059\059\059\059\059\059\059\059\059\059\059\059\059\059\
\\059\059\059\059\059\059\059\059\059\059\059\000\000\000\000\059\
\\000\059\059\059\059\059\059\059\059\059\059\059\059\059\059\059\
\\059\059\059\059\059\059\059\059\059\059\059\000\000\000\000\000\
\\000"
),
(60,
"\000\000\000\000\000\000\000\000\000\060\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\060\000\000\000\000\000\000\061\000\000\000\000\000\060\060\060\
\\060\060\060\060\060\060\060\060\060\060\000\000\000\000\000\000\
\\000\060\060\060\060\060\060\060\060\060\060\060\060\060\060\060\
\\060\060\060\060\060\060\060\060\060\060\060\000\000\000\000\060\
\\000\060\060\060\060\060\060\060\060\060\060\060\060\060\060\060\
\\060\060\060\060\060\060\060\060\060\060\060\000\000\000\000\000\
\\000"
),
(62,
"\063\063\063\063\063\063\063\063\063\063\064\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\063\
\\063"
),
(65,
"\000\000\000\000\000\000\000\000\000\066\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\066\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(0, "")]
fun f x = x
val s = List.map f (List.rev (tl (List.rev s)))
exception LexHackingError
fun look ((j,x)::r, i: int) = if i = j then x else look(r, i)
| look ([], i) = raise LexHackingError
fun g {fin=x, trans=i} = {fin=x, trans=look(s,i)}
in Vector.fromList(List.map g
[{fin = [], trans = 0},
{fin = [], trans = 1},
{fin = [], trans = 1},
{fin = [(N 97)], trans = 0},
{fin = [(N 95),(N 97)], trans = 4},
{fin = [(N 95)], trans = 5},
{fin = [(N 95)], trans = 6},
{fin = [(N 95)], trans = 7},
{fin = [(N 95)], trans = 8},
{fin = [(N 62),(N 95)], trans = 5},
{fin = [(N 95),(N 97)], trans = 5},
{fin = [(N 95),(N 97)], trans = 11},
{fin = [(N 95)], trans = 12},
{fin = [(N 95)], trans = 13},
{fin = [(N 95)], trans = 14},
{fin = [(N 39),(N 95)], trans = 5},
{fin = [(N 95),(N 97)], trans = 16},
{fin = [(N 95)], trans = 17},
{fin = [(N 57),(N 95)], trans = 5},
{fin = [(N 95),(N 97)], trans = 19},
{fin = [(N 95)], trans = 20},
{fin = [(N 95)], trans = 21},
{fin = [(N 95)], trans = 22},
{fin = [(N 95)], trans = 23},
{fin = [(N 69),(N 95)], trans = 5},
{fin = [(N 90),(N 97)], trans = 25},
{fin = [(N 90)], trans = 25},
{fin = [(N 90)], trans = 27},
{fin = [(N 90),(N 97)], trans = 28},
{fin = [(N 90)], trans = 29},
{fin = [(N 90)], trans = 30},
{fin = [(N 90)], trans = 31},
{fin = [(N 90)], trans = 32},
{fin = [(N 90)], trans = 33},
{fin = [(N 90)], trans = 34},
{fin = [(N 90)], trans = 35},
{fin = [(N 90)], trans = 36},
{fin = [(N 33),(N 90)], trans = 25},
{fin = [(N 97)], trans = 38},
{fin = [(N 53)], trans = 0},
{fin = [(N 41),(N 97)], trans = 0},
{fin = [(N 72),(N 97)], trans = 41},
{fin = [(N 72)], trans = 41},
{fin = [(N 97)], trans = 43},
{fin = [], trans = 44},
{fin = [], trans = 45},
{fin = [], trans = 46},
{fin = [], trans = 47},
{fin = [], trans = 48},
{fin = [(N 20)], trans = 0},
{fin = [], trans = 50},
{fin = [(N 20)], trans = 48},
{fin = [], trans = 44},
{fin = [(N 22),(N 97)], trans = 0},
{fin = [(N 50),(N 97)], trans = 54},
{fin = [(N 48)], trans = 0},
{fin = [(N 45),(N 97)], trans = 0},
{fin = [(N 43),(N 97)], trans = 0},
{fin = [(N 97)], trans = 58},
{fin = [], trans = 58},
{fin = [], trans = 60},
{fin = [(N 85)], trans = 0},
{fin = [(N 97)], trans = 62},
{fin = [], trans = 62},
{fin = [(N 8)], trans = 0},
{fin = [(N 4),(N 97)], trans = 65},
{fin = [(N 4)], trans = 65},
{fin = [(N 1)], trans = 0}])
end
structure StartStates =
struct
datatype yystartstate = STARTSTATE of int
val INITIAL = STARTSTATE 1;
end
type result = UserDeclarations.lexresult
exception LexerError
end
fun makeLexer yyinput =
let val yygone0=1
val yyb = Unsynchronized.ref "\n"
val yybl = Unsynchronized.ref 1
val yybufpos = Unsynchronized.ref 1
val yygone = Unsynchronized.ref yygone0
val yydone = Unsynchronized.ref false
val yybegin = Unsynchronized.ref 1
val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) =>
yybegin := x
fun lex () : Internal.result =
let fun continue() = lex() in
let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0) =
let fun action (i,nil) = raise LexError
| action (i,nil::l) = action (i-1,l)
| action (i,(node::acts)::l) =
case node of
Internal.N yyk =>
(let fun yymktext() = String.substring(!yyb,i0,i-i0)
val yypos = i0+ !yygone
open UserDeclarations Internal.StartStates
in (yybufpos := i; case yyk of
1 => (pos := ((#1 (!pos)) + 1, yypos - (#3(!pos)),yypos ); lex())
| 20 => (lex())
| 22 => let val yytext=yymktext() in Tokens.COMMA(yytext,inputPos_half yypos,inputPos_half yypos) end
| 33 => let val yytext=yymktext() in Tokens.FIXEDPOINT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 39 => let val yytext=yymktext() in Tokens.WHERE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 4 => (pos := (#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))); lex())
| 41 => let val yytext=yymktext() in Tokens.COLON(yytext,inputPos_half yypos,inputPos_half yypos) end
| 43 => let val yytext=yymktext() in Tokens.PAREN_OPEN(yytext,inputPos_half yypos,inputPos_half yypos) end
| 45 => let val yytext=yymktext() in Tokens.PAREN_CLOSE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 48 => let val yytext=yymktext() in Tokens.DOUBLE_ASTERISK(yytext,inputPos_half yypos,inputPos_half yypos) end
| 50 => let val yytext=yymktext() in Tokens.ASTERISK(yytext,inputPos_half yypos,inputPos_half yypos) end
| 53 => let val yytext=yymktext() in Tokens.DOUBLE_RARROW(yytext,inputPos_half yypos,inputPos_half yypos) end
| 57 => let val yytext=yymktext() in Tokens.ONE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 62 => let val yytext=yymktext() in Tokens.ZERO(yytext,inputPos_half yypos,inputPos_half yypos) end
| 69 => let val yytext=yymktext() in Tokens.ATTACK(yytext,inputPos_half yypos,inputPos_half yypos) end
| 72 => let val yytext=yymktext() in Tokens.INTEGER_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 8 => (pos := ((#1 (!pos)) + 1, yypos - (#3(!pos)),yypos ); lex())
| 85 => let val yytext=yymktext() in Tokens.STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 90 => let val yytext=yymktext() in Tokens.UPPER_STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 95 => let val yytext=yymktext() in Tokens.LOWER_STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 97 => let val yytext=yymktext() in error ("ignoring bad character "^yytext,
((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))),
((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))));
lex() end
| _ => raise Internal.LexerError
) end )
val {fin,trans} = Vector.sub(Internal.tab, s)
val NewAcceptingLeaves = fin::AcceptingLeaves
in if l = !yybl then
if trans = #trans(Vector.sub(Internal.tab,0))
then action(l,NewAcceptingLeaves
) else let val newchars= if !yydone then "" else yyinput 1024
in if (String.size newchars)=0
then (yydone := true;
if (l=i0) then UserDeclarations.eof ()
else action(l,NewAcceptingLeaves))
else (if i0=l then yyb := newchars
else yyb := String.substring(!yyb,i0,l-i0)^newchars;
yygone := !yygone+i0;
yybl := String.size (!yyb);
scan (s,AcceptingLeaves,l-i0,0))
end
else let val NewChar = Char.ord(CharVector.sub(!yyb,l))
val NewChar = if NewChar<128 then NewChar else 128
val NewState = Char.ord(CharVector.sub(trans,NewChar))
in if NewState=0 then action(l,NewAcceptingLeaves)
else scan(NewState,NewAcceptingLeaves,l+1,i0)
end
end
in scan(!yybegin ,nil,!yybufpos,!yybufpos)
end
end
in lex
end
end
File ‹trac_parser/trac_fp.grm.sml›
functor TracLrValsFun(structure Token : TOKEN)
: sig structure ParserData : PARSER_DATA
structure Tokens : Trac_TOKENS
end
=
struct
structure ParserData=
struct
structure Header =
struct
open Trac_Term
exception NotYetSupported of string
end
structure LrTable = Token.LrTable
structure Token = Token
local open LrTable in
val table=let val actionRows =
"\
\\001\000\001\000\000\000\000\000\
\\001\000\003\000\013\000\009\000\012\000\010\000\011\000\012\000\010\000\
\\013\000\009\000\000\000\
\\001\000\005\000\038\000\000\000\
\\001\000\005\000\047\000\000\000\
\\001\000\007\000\036\000\000\000\
\\001\000\008\000\028\000\012\000\010\000\013\000\009\000\014\000\027\000\
\\015\000\026\000\016\000\025\000\000\000\
\\001\000\008\000\032\000\012\000\010\000\000\000\
\\001\000\009\000\012\000\010\000\011\000\012\000\010\000\013\000\009\000\000\000\
\\001\000\010\000\019\000\000\000\
\\001\000\012\000\010\000\013\000\009\000\000\000\
\\001\000\012\000\010\000\013\000\009\000\017\000\018\000\000\000\
\\001\000\014\000\027\000\015\000\026\000\016\000\025\000\000\000\
\\051\000\000\000\
\\052\000\000\000\
\\053\000\000\000\
\\054\000\009\000\012\000\010\000\011\000\012\000\010\000\013\000\009\000\000\000\
\\055\000\000\000\
\\056\000\000\000\
\\057\000\000\000\
\\058\000\000\000\
\\059\000\000\000\
\\060\000\004\000\015\000\000\000\
\\061\000\004\000\033\000\000\000\
\\062\000\004\000\042\000\000\000\
\\063\000\000\000\
\\064\000\006\000\014\000\000\000\
\\065\000\000\000\
\\066\000\002\000\035\000\000\000\
\\067\000\000\000\
\\068\000\000\000\
\\069\000\000\000\
\\070\000\000\000\
\\071\000\008\000\032\000\012\000\010\000\000\000\
\\072\000\000\000\
\\073\000\000\000\
\\074\000\000\000\
\\075\000\000\000\
\\076\000\000\000\
\\077\000\000\000\
\\078\000\000\000\
\\079\000\000\000\
\\080\000\000\000\
\\081\000\000\000\
\"
val actionRowNumbers =
"\001\000\025\000\024\000\021\000\
\\015\000\014\000\012\000\037\000\
\\036\000\010\000\008\000\007\000\
\\005\000\006\000\016\000\022\000\
\\017\000\009\000\013\000\031\000\
\\027\000\004\000\029\000\041\000\
\\042\000\040\000\011\000\002\000\
\\032\000\018\000\011\000\006\000\
\\023\000\005\000\026\000\030\000\
\\009\000\033\000\003\000\019\000\
\\006\000\028\000\039\000\038\000\
\\035\000\009\000\020\000\034\000\
\\000\000"
val gotoT =
"\
\\001\000\048\000\002\000\006\000\003\000\005\000\004\000\004\000\
\\005\000\003\000\011\000\002\000\012\000\001\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\003\000\014\000\004\000\004\000\005\000\003\000\011\000\002\000\
\\012\000\001\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\015\000\011\000\002\000\012\000\001\000\000\000\
\\000\000\
\\003\000\018\000\004\000\004\000\005\000\003\000\011\000\002\000\
\\012\000\001\000\000\000\
\\005\000\022\000\006\000\021\000\007\000\020\000\011\000\002\000\
\\012\000\001\000\013\000\019\000\000\000\
\\008\000\029\000\009\000\028\000\011\000\027\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\032\000\011\000\002\000\012\000\001\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\013\000\035\000\000\000\
\\000\000\
\\008\000\037\000\009\000\028\000\011\000\027\000\000\000\
\\000\000\
\\013\000\038\000\000\000\
\\008\000\039\000\009\000\028\000\011\000\027\000\000\000\
\\000\000\
\\005\000\022\000\006\000\041\000\007\000\020\000\011\000\002\000\
\\012\000\001\000\013\000\019\000\000\000\
\\000\000\
\\000\000\
\\010\000\044\000\011\000\043\000\012\000\042\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\008\000\046\000\009\000\028\000\011\000\027\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\010\000\047\000\011\000\043\000\012\000\042\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\"
val numstates = 49
val numrules = 31
val s = Unsynchronized.ref "" and index = Unsynchronized.ref 0
val string_to_int = fn () =>
let val i = !index
in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256
end
val string_to_list = fn s' =>
let val len = String.size s'
fun f () =
if !index < len then string_to_int() :: f()
else nil
in index := 0; s := s'; f ()
end
val string_to_pairlist = fn (conv_key,conv_entry) =>
let fun f () =
case string_to_int()
of 0 => EMPTY
| n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f())
in f
end
val string_to_pairlist_default = fn (conv_key,conv_entry) =>
let val conv_row = string_to_pairlist(conv_key,conv_entry)
in fn () =>
let val default = conv_entry(string_to_int())
val row = conv_row()
in (row,default)
end
end
val string_to_table = fn (convert_row,s') =>
let val len = String.size s'
fun f ()=
if !index < len then convert_row() :: f()
else nil
in (s := s'; index := 0; f ())
end
local
val memo = Array.array(numstates+numrules,ERROR)
val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1))
fun f i =
if i=numstates then g i
else (Array.update(memo,i,SHIFT (STATE i)); f (i+1))
in f 0 handle General.Subscript => ()
end
in
val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2))
end
val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT))
val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows)
val actionRowNumbers = string_to_list actionRowNumbers
val actionT = let val actionRowLookUp=
let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end
in Array.fromList(List.map actionRowLookUp actionRowNumbers)
end
in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules,
numStates=numstates,initialState=STATE 0}
end
end
local open Header in
type pos = ( int * int * int )
type arg = unit
structure MlyValue =
struct
datatype svalue = VOID | ntVOID of unit -> unit
| ATTACK of unit -> (string) | ZERO of unit -> (string)
| ONE of unit -> (string) | INTEGER_LITERAL of unit -> (string)
| LOWER_STRING_LITERAL of unit -> (string)
| UPPER_STRING_LITERAL of unit -> (string)
| STRING_LITERAL of unit -> (string)
| DOUBLE_RARROW of unit -> (string)
| DOUBLE_ASTERISK of unit -> (string)
| ASTERISK of unit -> (string) | PAREN_CLOSE of unit -> (string)
| PAREN_OPEN of unit -> (string) | COLON of unit -> (string)
| WHERE of unit -> (string) | FIXEDPOINT of unit -> (string)
| COMMA of unit -> (string) | int_literal of unit -> (string)
| lower_literal of unit -> (string)
| upper_literal of unit -> (string)
| string_literal of unit -> (string)
| type_exp of unit -> (TypeDecl)
| type_list_exp of unit -> (TypeDecl list)
| arg_exp of unit -> (Msg) | arg_list_exp of unit -> (Msg list)
| rule_exp of unit -> (Msg)
| symfact_exp of unit -> (Msg*TypeDecl list)
| symfact_list_exp of unit -> ( ( Msg * TypeDecl list ) list)
| trac_file of unit -> ( ( Msg * TypeDecl list ) list)
| START of unit -> ( ( Msg * TypeDecl list ) list)
end
type svalue = MlyValue.svalue
type result = ( Msg * TypeDecl list ) list
end
structure EC=
struct
open LrTable
infix 5 $$
fun x $$ y = y::x
val is_keyword =
fn _ => false
val preferred_change : (term list * term list) list =
nil
val noShift =
fn (T 0) => true | _ => false
val showTerminal =
fn (T 0) => "EOF"
| (T 1) => "COMMA"
| (T 2) => "FIXEDPOINT"
| (T 3) => "WHERE"
| (T 4) => "COLON"
| (T 5) => "PAREN_OPEN"
| (T 6) => "PAREN_CLOSE"
| (T 7) => "ASTERISK"
| (T 8) => "DOUBLE_ASTERISK"
| (T 9) => "DOUBLE_RARROW"
| (T 10) => "STRING_LITERAL"
| (T 11) => "UPPER_STRING_LITERAL"
| (T 12) => "LOWER_STRING_LITERAL"
| (T 13) => "INTEGER_LITERAL"
| (T 14) => "ONE"
| (T 15) => "ZERO"
| (T 16) => "ATTACK"
| _ => "bogus-term"
local open Header in
val errtermvalue=
fn _ => MlyValue.VOID
end
val terms : term list = nil
$$ (T 0)end
structure Actions =
struct
exception mlyAction of int
local open Header in
val actions =
fn (i392,defaultPos,stack,
(()):arg) =>
case (i392,stack)
of ( 0, ( ( _, ( MlyValue.trac_file trac_file1, trac_file1left,
trac_file1right)) :: rest671)) => let val result = MlyValue.START (fn
_ => let val (trac_file as trac_file1) = trac_file1 ()
in (trac_file)
end)
in ( LrTable.NT 0, ( result, trac_file1left, trac_file1right),
rest671)
end
| ( 1, ( ( _, ( MlyValue.symfact_list_exp symfact_list_exp1, _,
symfact_list_exp1right)) :: ( _, ( MlyValue.FIXEDPOINT FIXEDPOINT1,
FIXEDPOINT1left, _)) :: rest671)) => let val result =
MlyValue.trac_file (fn _ => let val FIXEDPOINT1 = FIXEDPOINT1 ()
val (symfact_list_exp as symfact_list_exp1) = symfact_list_exp1 ()
in (symfact_list_exp)
end)
in ( LrTable.NT 1, ( result, FIXEDPOINT1left, symfact_list_exp1right)
, rest671)
end
| ( 2, ( ( _, ( MlyValue.symfact_list_exp symfact_list_exp1,
symfact_list_exp1left, symfact_list_exp1right)) :: rest671)) => let
val result = MlyValue.trac_file (fn _ => let val (symfact_list_exp
as symfact_list_exp1) = symfact_list_exp1 ()
in (symfact_list_exp)
end)
in ( LrTable.NT 1, ( result, symfact_list_exp1left,
symfact_list_exp1right), rest671)
end
| ( 3, ( ( _, ( MlyValue.symfact_exp symfact_exp1, symfact_exp1left,
symfact_exp1right)) :: rest671)) => let val result =
MlyValue.symfact_list_exp (fn _ => let val (symfact_exp as
symfact_exp1) = symfact_exp1 ()
in ([symfact_exp])
end)
in ( LrTable.NT 2, ( result, symfact_exp1left, symfact_exp1right),
rest671)
end
| ( 4, ( ( _, ( MlyValue.symfact_list_exp symfact_list_exp1, _,
symfact_list_exp1right)) :: ( _, ( MlyValue.symfact_exp symfact_exp1,
symfact_exp1left, _)) :: rest671)) => let val result =
MlyValue.symfact_list_exp (fn _ => let val (symfact_exp as
symfact_exp1) = symfact_exp1 ()
val (symfact_list_exp as symfact_list_exp1) = symfact_list_exp1 ()
in ([symfact_exp]@symfact_list_exp)
end)
in ( LrTable.NT 2, ( result, symfact_exp1left, symfact_list_exp1right
), rest671)
end
| ( 5, ( ( _, ( MlyValue.ATTACK ATTACK1, _, ATTACK1right)) :: ( _, (
MlyValue.DOUBLE_RARROW DOUBLE_RARROW1, DOUBLE_RARROW1left, _)) ::
rest671)) => let val result = MlyValue.symfact_exp (fn _ => let val
DOUBLE_RARROW1 = DOUBLE_RARROW1 ()
val ATTACK1 = ATTACK1 ()
in ((Attack,[]))
end)
in ( LrTable.NT 3, ( result, DOUBLE_RARROW1left, ATTACK1right),
rest671)
end
| ( 6, ( ( _, ( MlyValue.type_list_exp type_list_exp1, _,
type_list_exp1right)) :: ( _, ( MlyValue.WHERE WHERE1, _, _)) :: ( _,
( MlyValue.rule_exp rule_exp1, rule_exp1left, _)) :: rest671)) => let
val result = MlyValue.symfact_exp (fn _ => let val (rule_exp as
rule_exp1) = rule_exp1 ()
val WHERE1 = WHERE1 ()
val (type_list_exp as type_list_exp1) = type_list_exp1 ()
in ((rule_exp,type_list_exp))
end)
in ( LrTable.NT 3, ( result, rule_exp1left, type_list_exp1right),
rest671)
end
| ( 7, ( ( _, ( MlyValue.type_list_exp type_list_exp1, _,
type_list_exp1right)) :: ( _, ( MlyValue.WHERE WHERE1, _, _)) :: ( _,
( MlyValue.rule_exp rule_exp1, _, _)) :: ( _, ( MlyValue.DOUBLE_RARROW
DOUBLE_RARROW1, DOUBLE_RARROW1left, _)) :: rest671)) => let val
result = MlyValue.symfact_exp (fn _ => let val DOUBLE_RARROW1 =
DOUBLE_RARROW1 ()
val (rule_exp as rule_exp1) = rule_exp1 ()
val WHERE1 = WHERE1 ()
val (type_list_exp as type_list_exp1) = type_list_exp1 ()
in ((rule_exp,type_list_exp))
end)
in ( LrTable.NT 3, ( result, DOUBLE_RARROW1left, type_list_exp1right)
, rest671)
end
| ( 8, ( ( _, ( MlyValue.type_list_exp type_list_exp1, _,
type_list_exp1right)) :: ( _, ( MlyValue.WHERE WHERE1, _, _)) :: ( _,
( MlyValue.rule_exp rule_exp1, _, _)) :: ( _, ( MlyValue.DOUBLE_RARROW
DOUBLE_RARROW1, _, _)) :: ( _, ( MlyValue.DOUBLE_ASTERISK
DOUBLE_ASTERISK1, DOUBLE_ASTERISK1left, _)) :: rest671)) => let val
result = MlyValue.symfact_exp (fn _ => let val DOUBLE_ASTERISK1 =
DOUBLE_ASTERISK1 ()
val DOUBLE_RARROW1 = DOUBLE_RARROW1 ()
val (rule_exp as rule_exp1) = rule_exp1 ()
val WHERE1 = WHERE1 ()
val (type_list_exp as type_list_exp1) = type_list_exp1 ()
in ((rule_exp,type_list_exp))
end)
in ( LrTable.NT 3, ( result, DOUBLE_ASTERISK1left,
type_list_exp1right), rest671)
end
| ( 9, ( ( _, ( MlyValue.rule_exp rule_exp1, rule_exp1left,
rule_exp1right)) :: rest671)) => let val result =
MlyValue.symfact_exp (fn _ => let val (rule_exp as rule_exp1) =
rule_exp1 ()
in ((rule_exp,[]))
end)
in ( LrTable.NT 3, ( result, rule_exp1left, rule_exp1right), rest671)
end
| ( 10, ( ( _, ( MlyValue.rule_exp rule_exp1, _, rule_exp1right)) ::
( _, ( MlyValue.DOUBLE_RARROW DOUBLE_RARROW1, DOUBLE_RARROW1left, _))
:: rest671)) => let val result = MlyValue.symfact_exp (fn _ => let
val DOUBLE_RARROW1 = DOUBLE_RARROW1 ()
val (rule_exp as rule_exp1) = rule_exp1 ()
in ((rule_exp,[]))
end)
in ( LrTable.NT 3, ( result, DOUBLE_RARROW1left, rule_exp1right),
rest671)
end
| ( 11, ( ( _, ( MlyValue.rule_exp rule_exp1, _, rule_exp1right)) ::
( _, ( MlyValue.DOUBLE_RARROW DOUBLE_RARROW1, _, _)) :: ( _, (
MlyValue.DOUBLE_ASTERISK DOUBLE_ASTERISK1, DOUBLE_ASTERISK1left, _))
:: rest671)) => let val result = MlyValue.symfact_exp (fn _ => let
val DOUBLE_ASTERISK1 = DOUBLE_ASTERISK1 ()
val DOUBLE_RARROW1 = DOUBLE_RARROW1 ()
val (rule_exp as rule_exp1) = rule_exp1 ()
in ((rule_exp,[]))
end)
in ( LrTable.NT 3, ( result, DOUBLE_ASTERISK1left, rule_exp1right),
rest671)
end
| ( 12, ( ( _, ( MlyValue.upper_literal upper_literal1,
upper_literal1left, upper_literal1right)) :: rest671)) => let val
result = MlyValue.rule_exp (fn _ => let val (upper_literal as
upper_literal1) = upper_literal1 ()
in (Var (upper_literal))
end)
in ( LrTable.NT 4, ( result, upper_literal1left, upper_literal1right)
, rest671)
end
| ( 13, ( ( _, ( MlyValue.lower_literal lower_literal1,
lower_literal1left, lower_literal1right)) :: rest671)) => let val
result = MlyValue.rule_exp (fn _ => let val (lower_literal as
lower_literal1) = lower_literal1 ()
in (Fun (lower_literal,[]))
end)
in ( LrTable.NT 4, ( result, lower_literal1left, lower_literal1right)
, rest671)
end
| ( 14, ( ( _, ( MlyValue.PAREN_CLOSE PAREN_CLOSE1, _,
PAREN_CLOSE1right)) :: ( _, ( MlyValue.arg_list_exp arg_list_exp1, _,
_)) :: ( _, ( MlyValue.PAREN_OPEN PAREN_OPEN1, _, _)) :: ( _, (
MlyValue.lower_literal lower_literal1, lower_literal1left, _)) ::
rest671)) => let val result = MlyValue.rule_exp (fn _ => let val (
lower_literal as lower_literal1) = lower_literal1 ()
val PAREN_OPEN1 = PAREN_OPEN1 ()
val (arg_list_exp as arg_list_exp1) = arg_list_exp1 ()
val PAREN_CLOSE1 = PAREN_CLOSE1 ()
in (Fun (lower_literal,arg_list_exp))
end)
in ( LrTable.NT 4, ( result, lower_literal1left, PAREN_CLOSE1right),
rest671)
end
| ( 15, ( ( _, ( MlyValue.arg_exp arg_exp1, arg_exp1left,
arg_exp1right)) :: rest671)) => let val result =
MlyValue.arg_list_exp (fn _ => let val (arg_exp as arg_exp1) =
arg_exp1 ()
in ([arg_exp])
end)
in ( LrTable.NT 5, ( result, arg_exp1left, arg_exp1right), rest671)
end
| ( 16, ( ( _, ( MlyValue.arg_list_exp arg_list_exp1, _,
arg_list_exp1right)) :: ( _, ( MlyValue.COMMA COMMA1, _, _)) :: ( _, (
MlyValue.arg_exp arg_exp1, arg_exp1left, _)) :: rest671)) => let val
result = MlyValue.arg_list_exp (fn _ => let val (arg_exp as arg_exp1
) = arg_exp1 ()
val COMMA1 = COMMA1 ()
val (arg_list_exp as arg_list_exp1) = arg_list_exp1 ()
in ([arg_exp]@arg_list_exp)
end)
in ( LrTable.NT 5, ( result, arg_exp1left, arg_list_exp1right),
rest671)
end
| ( 17, ( ( _, ( MlyValue.rule_exp rule_exp1, rule_exp1left,
rule_exp1right)) :: rest671)) => let val result = MlyValue.arg_exp
(fn _ => let val (rule_exp as rule_exp1) = rule_exp1 ()
in (rule_exp)
end)
in ( LrTable.NT 6, ( result, rule_exp1left, rule_exp1right), rest671)
end
| ( 18, ( ( _, ( MlyValue.int_literal int_literal1, _,
int_literal1right)) :: ( _, ( MlyValue.ASTERISK ASTERISK1,
ASTERISK1left, _)) :: rest671)) => let val result = MlyValue.arg_exp
(fn _ => let val ASTERISK1 = ASTERISK1 ()
val (int_literal as int_literal1) = int_literal1 ()
in (Var (int_literal))
end)
in ( LrTable.NT 6, ( result, ASTERISK1left, int_literal1right),
rest671)
end
| ( 19, ( ( _, ( MlyValue.int_literal int_literal1, int_literal1left,
int_literal1right)) :: rest671)) => let val result =
MlyValue.arg_exp (fn _ => let val (int_literal as int_literal1) =
int_literal1 ()
in (Const (int_literal))
end)
in ( LrTable.NT 6, ( result, int_literal1left, int_literal1right),
rest671)
end
| ( 20, ( ( _, ( MlyValue.type_exp type_exp1, type_exp1left,
type_exp1right)) :: rest671)) => let val result =
MlyValue.type_list_exp (fn _ => let val (type_exp as type_exp1) =
type_exp1 ()
in ([type_exp])
end)
in ( LrTable.NT 7, ( result, type_exp1left, type_exp1right), rest671)
end
| ( 21, ( ( _, ( MlyValue.type_list_exp type_list_exp1, _,
type_list_exp1right)) :: ( _, ( MlyValue.type_exp type_exp1,
type_exp1left, _)) :: rest671)) => let val result =
MlyValue.type_list_exp (fn _ => let val (type_exp as type_exp1) =
type_exp1 ()
val (type_list_exp as type_list_exp1) = type_list_exp1 ()
in ([type_exp]@type_list_exp)
end)
in ( LrTable.NT 7, ( result, type_exp1left, type_list_exp1right),
rest671)
end
| ( 22, ( ( _, ( MlyValue.string_literal string_literal1, _,
string_literal1right)) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: ( _,
( MlyValue.int_literal int_literal1, _, _)) :: ( _, (
MlyValue.ASTERISK ASTERISK1, ASTERISK1left, _)) :: rest671)) => let
val result = MlyValue.type_exp (fn _ => let val ASTERISK1 =
ASTERISK1 ()
val (int_literal as int_literal1) = int_literal1 ()
val COLON1 = COLON1 ()
val (string_literal as string_literal1) = string_literal1 ()
in ((int_literal,string_literal))
end)
in ( LrTable.NT 8, ( result, ASTERISK1left, string_literal1right),
rest671)
end
| ( 23, ( ( _, ( MlyValue.string_literal string_literal1, _,
string_literal1right)) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: ( _,
( MlyValue.upper_literal upper_literal1, upper_literal1left, _)) ::
rest671)) => let val result = MlyValue.type_exp (fn _ => let val (
upper_literal as upper_literal1) = upper_literal1 ()
val COLON1 = COLON1 ()
val (string_literal as string_literal1) = string_literal1 ()
in ((upper_literal,string_literal))
end)
in ( LrTable.NT 8, ( result, upper_literal1left, string_literal1right
), rest671)
end
| ( 24, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.upper_literal (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in (UPPER_STRING_LITERAL)
end)
in ( LrTable.NT 10, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 25, ( ( _, ( MlyValue.LOWER_STRING_LITERAL LOWER_STRING_LITERAL1,
LOWER_STRING_LITERAL1left, LOWER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.lower_literal (fn _ => let val (
LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) = LOWER_STRING_LITERAL1
()
in (LOWER_STRING_LITERAL)
end)
in ( LrTable.NT 11, ( result, LOWER_STRING_LITERAL1left,
LOWER_STRING_LITERAL1right), rest671)
end
| ( 26, ( ( _, ( MlyValue.upper_literal upper_literal1,
upper_literal1left, upper_literal1right)) :: rest671)) => let val
result = MlyValue.string_literal (fn _ => let val (upper_literal as
upper_literal1) = upper_literal1 ()
in (upper_literal)
end)
in ( LrTable.NT 9, ( result, upper_literal1left, upper_literal1right)
, rest671)
end
| ( 27, ( ( _, ( MlyValue.lower_literal lower_literal1,
lower_literal1left, lower_literal1right)) :: rest671)) => let val
result = MlyValue.string_literal (fn _ => let val (lower_literal as
lower_literal1) = lower_literal1 ()
in (lower_literal)
end)
in ( LrTable.NT 9, ( result, lower_literal1left, lower_literal1right)
, rest671)
end
| ( 28, ( ( _, ( MlyValue.INTEGER_LITERAL INTEGER_LITERAL1,
INTEGER_LITERAL1left, INTEGER_LITERAL1right)) :: rest671)) => let val
result = MlyValue.int_literal (fn _ => let val (INTEGER_LITERAL as
INTEGER_LITERAL1) = INTEGER_LITERAL1 ()
in (INTEGER_LITERAL)
end)
in ( LrTable.NT 12, ( result, INTEGER_LITERAL1left,
INTEGER_LITERAL1right), rest671)
end
| ( 29, ( ( _, ( MlyValue.ZERO ZERO1, ZERO1left, ZERO1right)) ::
rest671)) => let val result = MlyValue.int_literal (fn _ => let val
ZERO1 = ZERO1 ()
in ("0")
end)
in ( LrTable.NT 12, ( result, ZERO1left, ZERO1right), rest671)
end
| ( 30, ( ( _, ( MlyValue.ONE ONE1, ONE1left, ONE1right)) :: rest671)
) => let val result = MlyValue.int_literal (fn _ => let val ONE1 =
ONE1 ()
in ("1")
end)
in ( LrTable.NT 12, ( result, ONE1left, ONE1right), rest671)
end
| _ => raise (mlyAction i392)
end
val void = MlyValue.VOID
val extract = fn a => (fn MlyValue.START x => x
| _ => let exception ParseInternal
in raise ParseInternal end) a ()
end
end
structure Tokens : Trac_TOKENS =
struct
type svalue = ParserData.svalue
type ('a,'b) token = ('a,'b) Token.token
fun EOF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 0,(
ParserData.MlyValue.VOID,p1,p2))
fun COMMA (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 1,(
ParserData.MlyValue.COMMA (fn () => i),p1,p2))
fun FIXEDPOINT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 2,(
ParserData.MlyValue.FIXEDPOINT (fn () => i),p1,p2))
fun WHERE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 3,(
ParserData.MlyValue.WHERE (fn () => i),p1,p2))
fun COLON (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 4,(
ParserData.MlyValue.COLON (fn () => i),p1,p2))
fun PAREN_OPEN (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 5,(
ParserData.MlyValue.PAREN_OPEN (fn () => i),p1,p2))
fun PAREN_CLOSE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 6,(
ParserData.MlyValue.PAREN_CLOSE (fn () => i),p1,p2))
fun ASTERISK (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 7,(
ParserData.MlyValue.ASTERISK (fn () => i),p1,p2))
fun DOUBLE_ASTERISK (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 8,(
ParserData.MlyValue.DOUBLE_ASTERISK (fn () => i),p1,p2))
fun DOUBLE_RARROW (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 9,(
ParserData.MlyValue.DOUBLE_RARROW (fn () => i),p1,p2))
fun STRING_LITERAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 10,(
ParserData.MlyValue.STRING_LITERAL (fn () => i),p1,p2))
fun UPPER_STRING_LITERAL (i,p1,p2) = Token.TOKEN (
ParserData.LrTable.T 11,(ParserData.MlyValue.UPPER_STRING_LITERAL
(fn () => i),p1,p2))
fun LOWER_STRING_LITERAL (i,p1,p2) = Token.TOKEN (
ParserData.LrTable.T 12,(ParserData.MlyValue.LOWER_STRING_LITERAL
(fn () => i),p1,p2))
fun INTEGER_LITERAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 13,(
ParserData.MlyValue.INTEGER_LITERAL (fn () => i),p1,p2))
fun ONE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 14,(
ParserData.MlyValue.ONE (fn () => i),p1,p2))
fun ZERO (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 15,(
ParserData.MlyValue.ZERO (fn () => i),p1,p2))
fun ATTACK (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 16,(
ParserData.MlyValue.ATTACK (fn () => i),p1,p2))
end
end
Theory trac_protocol_parser
section ‹Parser for the Trac Format›
theory
trac_protocol_parser
imports
"trac_term"
begin
ML_file "trac_parser/trac_protocol.grm.sig"
ML_file "trac_parser/trac_protocol.lex.sml"
ML_file "trac_parser/trac_protocol.grm.sml"
ML‹
structure TracProtocolParser : sig
val parse_file: string -> TracProtocol.protocol
val parse_str: string -> TracProtocol.protocol
end =
struct
structure TracLrVals =
TracTransactionLrValsFun(structure Token = LrParser.Token)
structure TracLex =
TracTransactionLexFun(structure Tokens = TracLrVals.Tokens)
structure TracParser =
Join(structure LrParser = LrParser
structure ParserData = TracLrVals.ParserData
structure Lex = TracLex)
fun invoke lexstream =
let fun print_error (s,i:(int * int * int),_) =
error("Error, line .... " ^ (Int.toString (#1 i)) ^"."^(Int.toString (#2 i ))^ ", " ^ s ^ "\n")
in TracParser.parse(0,lexstream,print_error,())
end
fun parse_fp lexer = let
val dummyEOF = TracLrVals.Tokens.EOF((0,0,0),(0,0,0))
fun loop lexer =
let
val _ = (TracLex.UserDeclarations.pos := (0,0,0);())
val (res,lexer) = invoke lexer
val (nextToken,lexer) = TracParser.Stream.get lexer
in if TracParser.sameToken(nextToken,dummyEOF) then ((),res)
else loop lexer
end
in (#2(loop lexer))
end
fun parse_file tracFile =
let
val infile = TextIO.openIn tracFile
val lexer = TracParser.makeLexer (fn _ => case ((TextIO.inputLine) infile) of
SOME s => s
| NONE => "")
in
parse_fp lexer
handle LrParser.ParseError => TracProtocol.empty
end
fun parse_str str =
let
val parsed = Unsynchronized.ref false
fun input_string _ = if !parsed then "" else (parsed := true ;str)
val lexer = TracParser.makeLexer input_string
in
parse_fp lexer
handle LrParser.ParseError => TracProtocol.empty
end
end
›
end
File ‹trac_parser/trac_protocol.grm.sig›
signature TracTransaction_TOKENS =
sig
type ('a,'b) token
type svalue
val OF: (string) * 'a * 'a -> (svalue,'a) token
val STAR: (string) * 'a * 'a -> (svalue,'a) token
val INTEGER_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val UNDERSCORE: (string) * 'a * 'a -> (svalue,'a) token
val LOWER_STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val UPPER_STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val STRING_LITERAL: (string) * 'a * 'a -> (svalue,'a) token
val TRANSACTIONS: (string) * 'a * 'a -> (svalue,'a) token
val ANALYSIS: (string) * 'a * 'a -> (svalue,'a) token
val ARROW: (string) * 'a * 'a -> (svalue,'a) token
val SETS: (string) * 'a * 'a -> (svalue,'a) token
val TYPES: (string) * 'a * 'a -> (svalue,'a) token
val equal: (string) * 'a * 'a -> (svalue,'a) token
val QUESTION: (string) * 'a * 'a -> (svalue,'a) token
val slash: (string) * 'a * 'a -> (svalue,'a) token
val ATTACK: (string) * 'a * 'a -> (svalue,'a) token
val NEW: (string) * 'a * 'a -> (svalue,'a) token
val DELETE: (string) * 'a * 'a -> (svalue,'a) token
val INSERT: (string) * 'a * 'a -> (svalue,'a) token
val NOTIN: (string) * 'a * 'a -> (svalue,'a) token
val IN: (string) * 'a * 'a -> (svalue,'a) token
val SEND: (string) * 'a * 'a -> (svalue,'a) token
val RECEIVE: (string) * 'a * 'a -> (svalue,'a) token
val PRIVATE: (string) * 'a * 'a -> (svalue,'a) token
val PUBLIC: (string) * 'a * 'a -> (svalue,'a) token
val FUNCTIONS: (string) * 'a * 'a -> (svalue,'a) token
val Sets: (string) * 'a * 'a -> (svalue,'a) token
val TBETWEEN: (string) * 'a * 'a -> (svalue,'a) token
val TSECRET: (string) * 'a * 'a -> (svalue,'a) token
val ON: (string) * 'a * 'a -> (svalue,'a) token
val WEAKLY: (string) * 'a * 'a -> (svalue,'a) token
val AUTHENTICATES: (string) * 'a * 'a -> (svalue,'a) token
val GOALS: (string) * 'a * 'a -> (svalue,'a) token
val ABSTRACTION: (string) * 'a * 'a -> (svalue,'a) token
val ACTIONS: (string) * 'a * 'a -> (svalue,'a) token
val WHERE: (string) * 'a * 'a -> (svalue,'a) token
val KNOWLEDGE: (string) * 'a * 'a -> (svalue,'a) token
val PROTOCOL: (string) * 'a * 'a -> (svalue,'a) token
val UNION: (string) * 'a * 'a -> (svalue,'a) token
val CLOSESQB: (string) * 'a * 'a -> (svalue,'a) token
val OPENSQB: (string) * 'a * 'a -> (svalue,'a) token
val COMMA: (string) * 'a * 'a -> (svalue,'a) token
val DOT: (string) * 'a * 'a -> (svalue,'a) token
val EXCLAM: (string) * 'a * 'a -> (svalue,'a) token
val UNEQUAL: (string) * 'a * 'a -> (svalue,'a) token
val PERCENT: (string) * 'a * 'a -> (svalue,'a) token
val FSECCH: (string) * 'a * 'a -> (svalue,'a) token
val FAUTHCH: (string) * 'a * 'a -> (svalue,'a) token
val INSECCH: (string) * 'a * 'a -> (svalue,'a) token
val CONFCH: (string) * 'a * 'a -> (svalue,'a) token
val AUTHCH: (string) * 'a * 'a -> (svalue,'a) token
val SECCH: (string) * 'a * 'a -> (svalue,'a) token
val SEMICOLON: (string) * 'a * 'a -> (svalue,'a) token
val COLON: (string) * 'a * 'a -> (svalue,'a) token
val CLOSESCRYPT: (string) * 'a * 'a -> (svalue,'a) token
val OPENSCRYPT: (string) * 'a * 'a -> (svalue,'a) token
val CLOSEB: (string) * 'a * 'a -> (svalue,'a) token
val OPENB: (string) * 'a * 'a -> (svalue,'a) token
val CLOSEP: (string) * 'a * 'a -> (svalue,'a) token
val OPENP: (string) * 'a * 'a -> (svalue,'a) token
val EOF: 'a * 'a -> (svalue,'a) token
end
signature TracTransaction_LRVALS=
sig
structure Tokens : TracTransaction_TOKENS
structure ParserData:PARSER_DATA
sharing type ParserData.Token.token = Tokens.token
sharing type ParserData.svalue = Tokens.svalue
end
File ‹trac_parser/trac_protocol.lex.sml›
functor TracTransactionLexFun(structure Tokens: TracTransaction_TOKENS)=
struct
structure UserDeclarations =
struct
structure Tokens = Tokens
open TracProtocol
type pos = int * int * int
type svalue = Tokens.svalue
type ('a,'b) token = ('a,'b) Tokens.token
type lexresult= (svalue,pos) token
val pos = Unsynchronized.ref (0,0,0)
fun eof () = Tokens.EOF((!pos,!pos))
fun error (e,p : (int * int * int),_) = TextIO.output (TextIO.stdOut,
String.concat[
"Line ", (Int.toString (#1 p)), "/",
(Int.toString (#2 p - #3 p)),": ", e, "\n"
])
fun inputPos yypos = ((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))),
(#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))))
fun inputPos_half yypos = (#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))
end
exception LexError
structure Internal =
struct
datatype yyfinstate = N of int
type statedata = {fin : yyfinstate list, trans: string}
val tab = let
val s = [
(0,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(1,
"\003\003\003\003\003\003\003\003\003\210\212\003\003\003\003\003\
\\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\
\\210\208\003\205\003\204\003\200\199\198\197\195\194\192\191\181\
\\179\179\179\179\179\179\179\179\179\179\178\177\003\176\003\175\
\\003\151\087\087\087\087\142\137\087\087\087\128\087\087\087\087\
\\110\087\087\106\090\087\087\087\087\087\087\086\003\085\003\084\
\\003\066\059\009\053\009\009\009\009\047\009\009\009\009\040\037\
\\009\009\030\022\009\009\009\012\009\009\009\007\005\004\003\003\
\\003"
),
(5,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000\
\\000"
),
(7,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\008\000\000\000\
\\000"
),
(9,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(11,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(12,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\017\010\010\013\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(13,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\014\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(14,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\015\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(15,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\016\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(17,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\018\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(18,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\019\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(19,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\020\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(20,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\021\010\000\000\000\000\000\
\\000"
),
(22,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\023\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(23,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\026\010\010\010\010\010\010\010\010\010\010\024\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(24,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\025\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(26,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\027\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(27,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\028\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(28,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\029\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(30,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\031\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(31,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\032\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(32,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\033\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(33,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\034\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(34,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\035\010\010\010\010\000\000\000\000\000\
\\000"
),
(35,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\036\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(37,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\039\010\010\010\010\010\010\010\038\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(40,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\045\010\010\010\010\010\010\010\010\010\041\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(41,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\042\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(42,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\043\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(43,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\044\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(45,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\046\010\010\010\000\000\000\000\000\
\\000"
),
(47,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\048\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(48,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\049\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(49,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\050\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(50,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\051\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(51,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\052\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(53,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\054\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(54,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\055\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(55,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\056\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(56,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\057\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(57,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\058\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(59,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\060\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(60,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\061\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(61,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\062\010\010\010\000\000\000\000\000\
\\000"
),
(62,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\063\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(63,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\064\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(64,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\065\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(66,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\079\067\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(67,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\068\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(68,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\069\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(69,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\070\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(70,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\071\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(71,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\072\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(72,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\073\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(73,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\074\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(74,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\075\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(75,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\076\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(76,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\077\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(77,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\078\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(79,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\080\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(80,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\081\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(81,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\082\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(82,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\
\\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\000\
\\000\010\010\010\010\010\010\010\010\010\010\010\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\010\
\\000\010\010\010\010\010\010\010\010\010\010\083\010\010\010\010\
\\010\010\010\010\010\010\010\010\010\010\010\000\000\000\000\000\
\\000"
),
(87,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(89,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(90,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\095\088\088\088\088\088\088\091\088\000\000\000\000\000\
\\000"
),
(91,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\092\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(92,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\093\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(93,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\094\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(95,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\096\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(96,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\097\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(97,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\098\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(98,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\099\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(99,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\100\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(100,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\101\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(101,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\102\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(102,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\103\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(103,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\104\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(104,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\105\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(106,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\107\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(107,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\108\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(108,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\109\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(110,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\116\088\088\111\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(111,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\112\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(112,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\113\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(113,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\114\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(114,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\115\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(116,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\123\088\088\088\088\088\117\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(117,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\118\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(118,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\119\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(119,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\120\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(120,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\121\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(121,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\122\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(123,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\124\088\088\088\088\000\000\000\000\000\
\\000"
),
(124,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\125\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(125,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\126\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(126,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\127\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(128,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\129\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(129,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\130\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(130,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\131\088\088\088\000\000\000\000\000\
\\000"
),
(131,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\132\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(132,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\133\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(133,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\134\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(134,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\135\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(135,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\136\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(137,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\138\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(138,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\139\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(139,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\140\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(140,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\141\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(142,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\143\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(143,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\144\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(144,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\145\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(145,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\146\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(146,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\147\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(147,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\148\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(148,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\149\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(149,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\150\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(151,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\165\159\088\088\088\088\088\088\088\088\088\088\152\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(152,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\153\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(153,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\154\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(154,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\155\088\000\000\000\000\000\
\\000"
),
(155,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\156\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(156,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\157\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(157,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\158\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(159,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\160\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(160,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\161\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(161,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\162\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(162,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\163\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(163,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\164\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(165,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\166\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(166,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\167\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(167,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\168\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(168,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\169\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(169,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\170\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(170,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\171\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(171,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\172\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(172,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\173\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(173,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\089\000\000\000\000\000\000\000\000\
\\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\000\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\088\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\088\
\\000\088\088\088\088\088\088\088\088\088\088\088\088\088\174\088\
\\088\088\088\088\088\088\088\088\088\088\088\000\000\000\000\000\
\\000"
),
(179,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\180\180\180\180\180\180\180\180\180\180\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(181,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\182\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(182,
"\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\184\183\183\183\183\190\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183"
),
(183,
"\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\184\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183"
),
(184,
"\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\188\185\185\185\185\187\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\185\
\\185"
),
(185,
"\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\184\183\183\183\183\186\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183"
),
(186,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\185\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(188,
"\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\184\183\183\183\183\189\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\183\
\\183"
),
(192,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\193\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(195,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\196\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(200,
"\000\000\000\000\000\000\000\000\000\201\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\201\000\000\000\000\000\000\203\000\000\000\000\000\202\202\202\
\\201\201\201\201\201\201\201\201\201\201\000\000\000\000\000\000\
\\000\201\201\201\201\201\201\201\201\201\201\201\201\201\201\201\
\\201\201\201\201\201\201\201\201\201\201\201\000\000\000\000\201\
\\000\201\201\201\201\201\201\201\201\201\201\201\201\201\201\201\
\\201\201\201\201\201\201\201\201\201\201\201\000\000\000\000\000\
\\000"
),
(202,
"\000\000\000\000\000\000\000\000\000\202\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\202\000\000\000\000\000\000\203\000\000\000\000\000\202\202\202\
\\202\202\202\202\202\202\202\202\202\202\000\000\000\000\000\000\
\\000\202\202\202\202\202\202\202\202\202\202\202\202\202\202\202\
\\202\202\202\202\202\202\202\202\202\202\202\000\000\000\000\202\
\\000\202\202\202\202\202\202\202\202\202\202\202\202\202\202\202\
\\202\202\202\202\202\202\202\202\202\202\202\000\000\000\000\000\
\\000"
),
(205,
"\206\206\206\206\206\206\206\206\206\206\207\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\206\
\\206"
),
(208,
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(210,
"\000\000\000\000\000\000\000\000\000\211\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000"
),
(0, "")]
fun f x = x
val s = List.map f (List.rev (tl (List.rev s)))
exception LexHackingError
fun look ((j,x)::r, i: int) = if i = j then x else look(r, i)
| look ([], i) = raise LexHackingError
fun g {fin=x, trans=i} = {fin=x, trans=look(s,i)}
in Vector.fromList(List.map g
[{fin = [], trans = 0},
{fin = [], trans = 1},
{fin = [], trans = 1},
{fin = [(N 295)], trans = 0},
{fin = [(N 28),(N 295)], trans = 0},
{fin = [(N 295)], trans = 5},
{fin = [(N 34)], trans = 0},
{fin = [(N 26),(N 295)], trans = 7},
{fin = [(N 31)], trans = 0},
{fin = [(N 288),(N 295)], trans = 9},
{fin = [(N 288)], trans = 9},
{fin = [(N 288)], trans = 11},
{fin = [(N 288),(N 295)], trans = 12},
{fin = [(N 288)], trans = 13},
{fin = [(N 288)], trans = 14},
{fin = [(N 288)], trans = 15},
{fin = [(N 84),(N 288)], trans = 9},
{fin = [(N 288)], trans = 17},
{fin = [(N 288)], trans = 18},
{fin = [(N 288)], trans = 19},
{fin = [(N 288)], trans = 20},
{fin = [(N 137),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 22},
{fin = [(N 288)], trans = 23},
{fin = [(N 288)], trans = 24},
{fin = [(N 220),(N 288)], trans = 9},
{fin = [(N 288)], trans = 26},
{fin = [(N 288)], trans = 27},
{fin = [(N 288)], trans = 28},
{fin = [(N 147),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 30},
{fin = [(N 288)], trans = 31},
{fin = [(N 288)], trans = 32},
{fin = [(N 288)], trans = 33},
{fin = [(N 288)], trans = 34},
{fin = [(N 288)], trans = 35},
{fin = [(N 215),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 37},
{fin = [(N 140),(N 288)], trans = 9},
{fin = [(N 267),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 40},
{fin = [(N 288)], trans = 41},
{fin = [(N 288)], trans = 42},
{fin = [(N 288)], trans = 43},
{fin = [(N 229),(N 288)], trans = 9},
{fin = [(N 288)], trans = 45},
{fin = [(N 247),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 47},
{fin = [(N 223),(N 288)], trans = 48},
{fin = [(N 288)], trans = 49},
{fin = [(N 288)], trans = 50},
{fin = [(N 288)], trans = 51},
{fin = [(N 236),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 53},
{fin = [(N 288)], trans = 54},
{fin = [(N 288)], trans = 55},
{fin = [(N 288)], trans = 56},
{fin = [(N 288)], trans = 57},
{fin = [(N 243),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 59},
{fin = [(N 288)], trans = 60},
{fin = [(N 288)], trans = 61},
{fin = [(N 288)], trans = 62},
{fin = [(N 288)], trans = 63},
{fin = [(N 288)], trans = 64},
{fin = [(N 155),(N 288)], trans = 9},
{fin = [(N 288),(N 295)], trans = 66},
{fin = [(N 288)], trans = 67},
{fin = [(N 288)], trans = 68},
{fin = [(N 288)], trans = 69},
{fin = [(N 288)], trans = 70},
{fin = [(N 288)], trans = 71},
{fin = [(N 288)], trans = 72},
{fin = [(N 288)], trans = 73},
{fin = [(N 288)], trans = 74},
{fin = [(N 288)], trans = 75},
{fin = [(N 288)], trans = 76},
{fin = [(N 288)], trans = 77},
{fin = [(N 130),(N 288)], trans = 9},
{fin = [(N 288)], trans = 79},
{fin = [(N 288)], trans = 80},
{fin = [(N 288)], trans = 81},
{fin = [(N 288)], trans = 82},
{fin = [(N 254),(N 288)], trans = 9},
{fin = [(N 262),(N 295)], trans = 0},
{fin = [(N 56),(N 295)], trans = 0},
{fin = [(N 54),(N 295)], trans = 0},
{fin = [(N 293),(N 295)], trans = 87},
{fin = [(N 293)], trans = 87},
{fin = [(N 293)], trans = 89},
{fin = [(N 293),(N 295)], trans = 90},
{fin = [(N 293)], trans = 91},
{fin = [(N 293)], trans = 92},
{fin = [(N 293)], trans = 93},
{fin = [(N 90),(N 293)], trans = 87},
{fin = [(N 293)], trans = 95},
{fin = [(N 293)], trans = 96},
{fin = [(N 293)], trans = 97},
{fin = [(N 293)], trans = 98},
{fin = [(N 293)], trans = 99},
{fin = [(N 293)], trans = 100},
{fin = [(N 293)], trans = 101},
{fin = [(N 293)], trans = 102},
{fin = [(N 293)], trans = 103},
{fin = [(N 293)], trans = 104},
{fin = [(N 207),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 106},
{fin = [(N 293)], trans = 107},
{fin = [(N 293)], trans = 108},
{fin = [(N 160),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 110},
{fin = [(N 293)], trans = 111},
{fin = [(N 293)], trans = 112},
{fin = [(N 293)], trans = 113},
{fin = [(N 293)], trans = 114},
{fin = [(N 177),(N 293)], trans = 87},
{fin = [(N 293)], trans = 116},
{fin = [(N 293)], trans = 117},
{fin = [(N 293)], trans = 118},
{fin = [(N 293)], trans = 119},
{fin = [(N 293)], trans = 120},
{fin = [(N 293)], trans = 121},
{fin = [(N 68),(N 293)], trans = 87},
{fin = [(N 293)], trans = 123},
{fin = [(N 293)], trans = 124},
{fin = [(N 293)], trans = 125},
{fin = [(N 293)], trans = 126},
{fin = [(N 185),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 128},
{fin = [(N 293)], trans = 129},
{fin = [(N 293)], trans = 130},
{fin = [(N 293)], trans = 131},
{fin = [(N 293)], trans = 132},
{fin = [(N 293)], trans = 133},
{fin = [(N 293)], trans = 134},
{fin = [(N 293)], trans = 135},
{fin = [(N 78),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 137},
{fin = [(N 293)], trans = 138},
{fin = [(N 293)], trans = 139},
{fin = [(N 293)], trans = 140},
{fin = [(N 116),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 142},
{fin = [(N 293)], trans = 143},
{fin = [(N 293)], trans = 144},
{fin = [(N 293)], trans = 145},
{fin = [(N 293)], trans = 146},
{fin = [(N 293)], trans = 147},
{fin = [(N 293)], trans = 148},
{fin = [(N 293)], trans = 149},
{fin = [(N 170),(N 293)], trans = 87},
{fin = [(N 293),(N 295)], trans = 151},
{fin = [(N 293)], trans = 152},
{fin = [(N 293)], trans = 153},
{fin = [(N 293)], trans = 154},
{fin = [(N 293)], trans = 155},
{fin = [(N 293)], trans = 156},
{fin = [(N 293)], trans = 157},
{fin = [(N 194),(N 293)], trans = 87},
{fin = [(N 293)], trans = 159},
{fin = [(N 293)], trans = 160},
{fin = [(N 293)], trans = 161},
{fin = [(N 293)], trans = 162},
{fin = [(N 293)], trans = 163},
{fin = [(N 98),(N 293)], trans = 87},
{fin = [(N 293)], trans = 165},
{fin = [(N 293)], trans = 166},
{fin = [(N 293)], trans = 167},
{fin = [(N 293)], trans = 168},
{fin = [(N 293)], trans = 169},
{fin = [(N 293)], trans = 170},
{fin = [(N 293)], trans = 171},
{fin = [(N 293)], trans = 172},
{fin = [(N 293)], trans = 173},
{fin = [(N 110),(N 293)], trans = 87},
{fin = [(N 258),(N 295)], trans = 0},
{fin = [(N 260),(N 295)], trans = 0},
{fin = [(N 38),(N 295)], trans = 0},
{fin = [(N 36),(N 295)], trans = 0},
{fin = [(N 270),(N 295)], trans = 179},
{fin = [(N 270)], trans = 179},
{fin = [(N 256),(N 295)], trans = 181},
{fin = [], trans = 182},
{fin = [], trans = 183},
{fin = [], trans = 184},
{fin = [], trans = 185},
{fin = [], trans = 186},
{fin = [(N 20)], trans = 0},
{fin = [], trans = 188},
{fin = [(N 20)], trans = 186},
{fin = [], trans = 182},
{fin = [(N 50),(N 295)], trans = 0},
{fin = [(N 295)], trans = 192},
{fin = [(N 41)], trans = 0},
{fin = [(N 52),(N 295)], trans = 0},
{fin = [(N 295)], trans = 195},
{fin = [(N 59)], trans = 0},
{fin = [(N 264),(N 295)], trans = 0},
{fin = [(N 24),(N 295)], trans = 0},
{fin = [(N 22),(N 295)], trans = 0},
{fin = [(N 295)], trans = 200},
{fin = [], trans = 200},
{fin = [], trans = 202},
{fin = [(N 283)], trans = 0},
{fin = [(N 43),(N 295)], trans = 0},
{fin = [(N 295)], trans = 205},
{fin = [], trans = 205},
{fin = [(N 8)], trans = 0},
{fin = [(N 48),(N 295)], trans = 208},
{fin = [(N 46)], trans = 0},
{fin = [(N 4),(N 295)], trans = 210},
{fin = [(N 4)], trans = 210},
{fin = [(N 1)], trans = 0}])
end
structure StartStates =
struct
datatype yystartstate = STARTSTATE of int
val INITIAL = STARTSTATE 1;
end
type result = UserDeclarations.lexresult
exception LexerError
end
fun makeLexer yyinput =
let val yygone0=1
val yyb = Unsynchronized.ref "\n"
val yybl = Unsynchronized.ref 1
val yybufpos = Unsynchronized.ref 1
val yygone = Unsynchronized.ref yygone0
val yydone = Unsynchronized.ref false
val yybegin = Unsynchronized.ref 1
val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) =>
yybegin := x
fun lex () : Internal.result =
let fun continue() = lex() in
let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0) =
let fun action (i,nil) = raise LexError
| action (i,nil::l) = action (i-1,l)
| action (i,(node::acts)::l) =
case node of
Internal.N yyk =>
(let fun yymktext() = String.substring(!yyb,i0,i-i0)
val yypos = i0+ !yygone
open UserDeclarations Internal.StartStates
in (yybufpos := i; case yyk of
1 => (pos := ((#1 (!pos)) + 1, yypos - (#3(!pos)),yypos ); lex())
| 110 => let val yytext=yymktext() in Tokens.ABSTRACTION(yytext,inputPos_half yypos,inputPos_half yypos) end
| 116 => let val yytext=yymktext() in Tokens.GOALS(yytext,inputPos_half yypos,inputPos_half yypos) end
| 130 => let val yytext=yymktext() in Tokens.AUTHENTICATES(yytext,inputPos_half yypos,inputPos_half yypos) end
| 137 => let val yytext=yymktext() in Tokens.WEAKLY(yytext,inputPos_half yypos,inputPos_half yypos) end
| 140 => let val yytext=yymktext() in Tokens.ON(yytext,inputPos_half yypos,inputPos_half yypos) end
| 147 => let val yytext=yymktext() in Tokens.TSECRET(yytext,inputPos_half yypos,inputPos_half yypos) end
| 155 => let val yytext=yymktext() in Tokens.TBETWEEN(yytext,inputPos_half yypos,inputPos_half yypos) end
| 160 => let val yytext=yymktext() in Tokens.SETS(yytext,inputPos_half yypos,inputPos_half yypos) end
| 170 => let val yytext=yymktext() in Tokens.FUNCTIONS(yytext,inputPos_half yypos,inputPos_half yypos) end
| 177 => let val yytext=yymktext() in Tokens.PUBLIC(yytext,inputPos_half yypos,inputPos_half yypos) end
| 185 => let val yytext=yymktext() in Tokens.PRIVATE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 194 => let val yytext=yymktext() in Tokens.ANALYSIS(yytext,inputPos_half yypos,inputPos_half yypos) end
| 20 => (lex())
| 207 => let val yytext=yymktext() in Tokens.TRANSACTIONS(yytext,inputPos_half yypos,inputPos_half yypos) end
| 215 => let val yytext=yymktext() in Tokens.RECEIVE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 22 => let val yytext=yymktext() in Tokens.OPENP(yytext,inputPos_half yypos,inputPos_half yypos) end
| 220 => let val yytext=yymktext() in Tokens.SEND(yytext,inputPos_half yypos,inputPos_half yypos) end
| 223 => let val yytext=yymktext() in Tokens.IN(yytext,inputPos_half yypos,inputPos_half yypos) end
| 229 => let val yytext=yymktext() in Tokens.NOTIN(yytext,inputPos_half yypos,inputPos_half yypos) end
| 236 => let val yytext=yymktext() in Tokens.INSERT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 24 => let val yytext=yymktext() in Tokens.CLOSEP(yytext,inputPos_half yypos,inputPos_half yypos) end
| 243 => let val yytext=yymktext() in Tokens.DELETE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 247 => let val yytext=yymktext() in Tokens.NEW(yytext,inputPos_half yypos,inputPos_half yypos) end
| 254 => let val yytext=yymktext() in Tokens.ATTACK(yytext,inputPos_half yypos,inputPos_half yypos) end
| 256 => let val yytext=yymktext() in Tokens.slash(yytext,inputPos_half yypos,inputPos_half yypos) end
| 258 => let val yytext=yymktext() in Tokens.QUESTION(yytext,inputPos_half yypos,inputPos_half yypos) end
| 26 => let val yytext=yymktext() in Tokens.OPENB(yytext,inputPos_half yypos,inputPos_half yypos) end
| 260 => let val yytext=yymktext() in Tokens.equal(yytext,inputPos_half yypos,inputPos_half yypos) end
| 262 => let val yytext=yymktext() in Tokens.UNDERSCORE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 264 => let val yytext=yymktext() in Tokens.STAR(yytext,inputPos_half yypos,inputPos_half yypos) end
| 267 => let val yytext=yymktext() in Tokens.OF(yytext,inputPos_half yypos,inputPos_half yypos) end
| 270 => let val yytext=yymktext() in Tokens.INTEGER_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 28 => let val yytext=yymktext() in Tokens.CLOSEB(yytext,inputPos_half yypos,inputPos_half yypos) end
| 283 => let val yytext=yymktext() in Tokens.STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 288 => let val yytext=yymktext() in Tokens.LOWER_STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 293 => let val yytext=yymktext() in Tokens.UPPER_STRING_LITERAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 295 => let val yytext=yymktext() in error ("ignoring bad character "^yytext,
((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))),
((#1 (!pos), yypos - (#3(!pos)), (#3 (!pos)))));
lex() end
| 31 => let val yytext=yymktext() in Tokens.OPENSCRYPT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 34 => let val yytext=yymktext() in Tokens.CLOSESCRYPT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 36 => let val yytext=yymktext() in Tokens.COLON(yytext,inputPos_half yypos,inputPos_half yypos) end
| 38 => let val yytext=yymktext() in Tokens.SEMICOLON(yytext,inputPos_half yypos,inputPos_half yypos) end
| 4 => (pos := (#1 (!pos), yypos - (#3(!pos)), (#3 (!pos))); lex())
| 41 => let val yytext=yymktext() in Tokens.ARROW(yytext,inputPos_half yypos,inputPos_half yypos) end
| 43 => let val yytext=yymktext() in Tokens.PERCENT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 46 => let val yytext=yymktext() in Tokens.UNEQUAL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 48 => let val yytext=yymktext() in Tokens.EXCLAM (yytext,inputPos_half yypos,inputPos_half yypos) end
| 50 => let val yytext=yymktext() in Tokens.DOT(yytext,inputPos_half yypos,inputPos_half yypos) end
| 52 => let val yytext=yymktext() in Tokens.COMMA(yytext,inputPos_half yypos,inputPos_half yypos) end
| 54 => let val yytext=yymktext() in Tokens.OPENSQB(yytext,inputPos_half yypos,inputPos_half yypos) end
| 56 => let val yytext=yymktext() in Tokens.CLOSESQB(yytext,inputPos_half yypos,inputPos_half yypos) end
| 59 => let val yytext=yymktext() in Tokens.UNION(yytext,inputPos_half yypos,inputPos_half yypos) end
| 68 => let val yytext=yymktext() in Tokens.PROTOCOL(yytext,inputPos_half yypos,inputPos_half yypos) end
| 78 => let val yytext=yymktext() in Tokens.KNOWLEDGE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 8 => (pos := ((#1 (!pos)) + 1, yypos - (#3(!pos)),yypos ); lex())
| 84 => let val yytext=yymktext() in Tokens.WHERE(yytext,inputPos_half yypos,inputPos_half yypos) end
| 90 => let val yytext=yymktext() in Tokens.TYPES(yytext,inputPos_half yypos,inputPos_half yypos) end
| 98 => let val yytext=yymktext() in Tokens.ACTIONS(yytext,inputPos_half yypos,inputPos_half yypos) end
| _ => raise Internal.LexerError
) end )
val {fin,trans} = Vector.sub(Internal.tab, s)
val NewAcceptingLeaves = fin::AcceptingLeaves
in if l = !yybl then
if trans = #trans(Vector.sub(Internal.tab,0))
then action(l,NewAcceptingLeaves
) else let val newchars= if !yydone then "" else yyinput 1024
in if (String.size newchars)=0
then (yydone := true;
if (l=i0) then UserDeclarations.eof ()
else action(l,NewAcceptingLeaves))
else (if i0=l then yyb := newchars
else yyb := String.substring(!yyb,i0,l-i0)^newchars;
yygone := !yygone+i0;
yybl := String.size (!yyb);
scan (s,AcceptingLeaves,l-i0,0))
end
else let val NewChar = Char.ord(CharVector.sub(!yyb,l))
val NewChar = if NewChar<128 then NewChar else 128
val NewState = Char.ord(CharVector.sub(trans,NewChar))
in if NewState=0 then action(l,NewAcceptingLeaves)
else scan(NewState,NewAcceptingLeaves,l+1,i0)
end
end
in scan(!yybegin ,nil,!yybufpos,!yybufpos)
end
end
in lex
end
end
File ‹trac_parser/trac_protocol.grm.sml›
functor TracTransactionLrValsFun(structure Token : TOKEN)
: sig structure ParserData : PARSER_DATA
structure Tokens : TracTransaction_TOKENS
end
=
struct
structure ParserData=
struct
structure Header =
struct
open Trac_Term
exception NotYetSupported of string
end
structure LrTable = Token.LrTable
structure Token = Token
local open LrTable in
val table=let val actionRows =
"\
\\001\000\001\000\000\000\000\000\
\\001\000\002\000\058\000\000\000\
\\001\000\002\000\063\000\000\000\
\\001\000\003\000\095\000\056\000\028\000\057\000\027\000\000\000\
\\001\000\003\000\124\000\000\000\
\\001\000\003\000\130\000\000\000\
\\001\000\003\000\138\000\000\000\
\\001\000\003\000\163\000\000\000\
\\001\000\003\000\164\000\000\000\
\\001\000\003\000\169\000\000\000\
\\001\000\004\000\107\000\056\000\028\000\057\000\027\000\000\000\
\\001\000\005\000\154\000\000\000\
\\001\000\008\000\005\000\000\000\
\\001\000\008\000\016\000\000\000\
\\001\000\008\000\018\000\000\000\
\\001\000\008\000\019\000\000\000\
\\001\000\008\000\020\000\000\000\
\\001\000\008\000\021\000\000\000\
\\001\000\008\000\126\000\000\000\
\\001\000\017\000\168\000\000\000\
\\001\000\019\000\077\000\000\000\
\\001\000\024\000\004\000\000\000\
\\001\000\039\000\056\000\040\000\055\000\043\000\054\000\044\000\053\000\
\\045\000\052\000\046\000\051\000\056\000\028\000\057\000\027\000\
\\060\000\050\000\000\000\
\\001\000\039\000\086\000\040\000\085\000\043\000\084\000\044\000\083\000\
\\056\000\028\000\057\000\027\000\000\000\
\\001\000\041\000\080\000\042\000\079\000\000\000\
\\001\000\041\000\117\000\042\000\116\000\000\000\
\\001\000\047\000\066\000\000\000\
\\001\000\047\000\109\000\000\000\
\\001\000\048\000\060\000\052\000\059\000\000\000\
\\001\000\049\000\069\000\000\000\
\\001\000\052\000\129\000\000\000\
\\001\000\056\000\008\000\057\000\007\000\000\000\
\\001\000\056\000\028\000\000\000\
\\001\000\056\000\028\000\057\000\027\000\000\000\
\\001\000\056\000\028\000\057\000\027\000\058\000\157\000\000\000\
\\001\000\056\000\028\000\057\000\027\000\058\000\165\000\000\000\
\\001\000\056\000\097\000\000\000\
\\001\000\056\000\102\000\000\000\
\\001\000\056\000\148\000\057\000\147\000\000\000\
\\001\000\056\000\161\000\000\000\
\\001\000\056\000\171\000\000\000\
\\001\000\057\000\027\000\000\000\
\\001\000\057\000\029\000\000\000\
\\001\000\057\000\033\000\000\000\
\\001\000\059\000\104\000\000\000\
\\173\000\000\000\
\\174\000\000\000\
\\175\000\000\000\
\\176\000\000\000\
\\177\000\000\000\
\\178\000\000\000\
\\179\000\000\000\
\\180\000\036\000\015\000\050\000\014\000\051\000\013\000\053\000\012\000\
\\054\000\011\000\000\000\
\\181\000\023\000\132\000\000\000\
\\182\000\000\000\
\\183\000\056\000\028\000\057\000\027\000\000\000\
\\184\000\000\000\
\\185\000\000\000\
\\186\000\000\000\
\\187\000\056\000\028\000\057\000\027\000\000\000\
\\188\000\000\000\
\\189\000\000\000\
\\190\000\000\000\
\\191\000\000\000\
\\192\000\037\000\044\000\038\000\043\000\000\000\
\\193\000\000\000\
\\194\000\000\000\
\\195\000\056\000\028\000\057\000\027\000\000\000\
\\196\000\000\000\
\\197\000\000\000\
\\198\000\057\000\033\000\000\000\
\\199\000\000\000\
\\200\000\000\000\
\\201\000\000\000\
\\202\000\000\000\
\\203\000\020\000\131\000\000\000\
\\204\000\000\000\
\\205\000\000\000\
\\206\000\020\000\127\000\000\000\
\\207\000\000\000\
\\208\000\061\000\017\000\000\000\
\\209\000\000\000\
\\210\000\056\000\028\000\057\000\027\000\000\000\
\\211\000\000\000\
\\212\000\000\000\
\\213\000\000\000\
\\214\000\020\000\166\000\000\000\
\\215\000\000\000\
\\216\000\000\000\
\\217\000\026\000\144\000\000\000\
\\218\000\000\000\
\\219\000\020\000\125\000\000\000\
\\220\000\000\000\
\\221\000\000\000\
\\222\000\000\000\
\\223\000\000\000\
\\224\000\039\000\056\000\040\000\055\000\043\000\054\000\044\000\053\000\
\\045\000\052\000\046\000\051\000\056\000\028\000\057\000\027\000\
\\060\000\050\000\000\000\
\\225\000\000\000\
\\226\000\000\000\
\\227\000\000\000\
\\228\000\000\000\
\\229\000\000\000\
\\230\000\000\000\
\\231\000\000\000\
\\232\000\000\000\
\\233\000\000\000\
\\234\000\000\000\
\\235\000\000\000\
\\236\000\000\000\
\\237\000\000\000\
\\238\000\000\000\
\\239\000\000\000\
\\240\000\000\000\
\\241\000\000\000\
\\242\000\002\000\136\000\000\000\
\\242\000\002\000\137\000\000\000\
\\242\000\002\000\158\000\000\000\
\\243\000\000\000\
\\244\000\000\000\
\\245\000\002\000\081\000\000\000\
\\246\000\000\000\
\\247\000\020\000\128\000\000\000\
\\248\000\000\000\
\\249\000\000\000\
\\250\000\000\000\
\\251\000\000\000\
\\254\000\000\000\
\\255\000\020\000\155\000\000\000\
\\000\001\000\000\
\\001\001\000\000\
\\002\001\000\000\
\\005\001\000\000\
\"
val actionRowNumbers =
"\021\000\045\000\012\000\031\000\
\\052\000\124\000\123\000\013\000\
\\046\000\080\000\014\000\015\000\
\\016\000\017\000\033\000\042\000\
\\043\000\033\000\033\000\064\000\
\\022\000\052\000\001\000\130\000\
\\129\000\126\000\125\000\081\000\
\\028\000\070\000\052\000\002\000\
\\059\000\052\000\026\000\052\000\
\\055\000\029\000\064\000\064\000\
\\052\000\033\000\033\000\020\000\
\\096\000\024\000\119\000\118\000\
\\023\000\106\000\032\000\033\000\
\\033\000\033\000\033\000\051\000\
\\003\000\036\000\033\000\071\000\
\\050\000\037\000\060\000\048\000\
\\044\000\047\000\056\000\010\000\
\\062\000\063\000\049\000\067\000\
\\066\000\027\000\065\000\082\000\
\\097\000\041\000\041\000\033\000\
\\025\000\033\000\033\000\033\000\
\\033\000\105\000\041\000\041\000\
\\099\000\098\000\004\000\091\000\
\\018\000\090\000\072\000\078\000\
\\077\000\121\000\030\000\005\000\
\\075\000\061\000\131\000\058\000\
\\053\000\041\000\068\000\044\000\
\\083\000\101\000\114\000\100\000\
\\115\000\006\000\041\000\041\000\
\\041\000\041\000\108\000\107\000\
\\104\000\103\000\089\000\033\000\
\\038\000\036\000\033\000\036\000\
\\074\000\037\000\033\000\011\000\
\\127\000\069\000\034\000\033\000\
\\120\000\110\000\116\000\109\000\
\\113\000\112\000\039\000\092\000\
\\093\000\095\000\094\000\079\000\
\\122\000\073\000\076\000\054\000\
\\057\000\041\000\007\000\008\000\
\\035\000\088\000\086\000\019\000\
\\128\000\117\000\102\000\009\000\
\\039\000\085\000\040\000\111\000\
\\087\000\084\000\000\000"
val gotoT =
"\
\\001\000\170\000\007\000\001\000\000\000\
\\000\000\
\\000\000\
\\002\000\004\000\000\000\
\\008\000\008\000\023\000\007\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\022\000\024\000\021\000\
\\038\000\020\000\000\000\
\\000\000\
\\022\000\030\000\025\000\029\000\026\000\028\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\034\000\015\000\033\000\
\\016\000\032\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\037\000\010\000\036\000\
\\011\000\035\000\000\000\
\\017\000\040\000\020\000\039\000\021\000\038\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\045\000\033\000\044\000\
\\034\000\043\000\000\000\
\\008\000\055\000\023\000\007\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\022\000\059\000\025\000\029\000\026\000\028\000\000\000\
\\008\000\060\000\023\000\007\000\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\034\000\015\000\062\000\
\\016\000\032\000\000\000\
\\008\000\063\000\023\000\007\000\000\000\
\\000\000\
\\008\000\065\000\023\000\007\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\037\000\010\000\036\000\
\\011\000\066\000\000\000\
\\000\000\
\\017\000\068\000\020\000\039\000\021\000\038\000\000\000\
\\017\000\069\000\020\000\039\000\021\000\038\000\000\000\
\\008\000\070\000\023\000\007\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\073\000\018\000\072\000\
\\019\000\071\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\073\000\018\000\074\000\
\\019\000\071\000\000\000\
\\000\000\
\\004\000\047\000\005\000\046\000\030\000\045\000\033\000\044\000\
\\034\000\076\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\047\000\005\000\046\000\030\000\080\000\000\000\
\\000\000\
\\004\000\085\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\086\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\087\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\088\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\089\000\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\092\000\040\000\091\000\
\\041\000\090\000\000\000\
\\029\000\094\000\000\000\
\\004\000\047\000\005\000\046\000\028\000\098\000\030\000\097\000\
\\031\000\096\000\000\000\
\\000\000\
\\000\000\
\\027\000\099\000\000\000\
\\000\000\
\\000\000\
\\003\000\101\000\000\000\
\\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\104\000\009\000\103\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\073\000\018\000\106\000\
\\019\000\071\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\022\000\024\000\108\000\
\\038\000\020\000\000\000\
\\000\000\
\\005\000\110\000\032\000\109\000\000\000\
\\005\000\112\000\032\000\111\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\097\000\031\000\113\000\000\000\
\\000\000\
\\004\000\047\000\005\000\046\000\030\000\116\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\117\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\118\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\119\000\000\000\
\\000\000\
\\005\000\112\000\032\000\120\000\000\000\
\\005\000\112\000\032\000\121\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\132\000\014\000\131\000\000\000\
\\000\000\
\\003\000\133\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\138\000\032\000\137\000\000\000\
\\005\000\112\000\032\000\139\000\000\000\
\\005\000\112\000\032\000\140\000\000\000\
\\005\000\112\000\032\000\141\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\024\000\005\000\023\000\006\000\092\000\040\000\091\000\
\\041\000\143\000\000\000\
\\039\000\144\000\000\000\
\\029\000\147\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\097\000\031\000\148\000\000\000\
\\029\000\149\000\000\000\
\\000\000\
\\027\000\150\000\000\000\
\\004\000\024\000\005\000\023\000\006\000\104\000\009\000\151\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\004\000\047\000\005\000\046\000\030\000\097\000\031\000\154\000\000\000\
\\004\000\047\000\005\000\046\000\030\000\097\000\031\000\154\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\036\000\158\000\037\000\157\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\132\000\014\000\160\000\000\000\
\\000\000\
\\000\000\
\\004\000\047\000\005\000\046\000\030\000\097\000\031\000\154\000\000\000\
\\000\000\
\\000\000\
\\035\000\165\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\036\000\158\000\037\000\168\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\"
val numstates = 171
val numrules = 89
val s = Unsynchronized.ref "" and index = Unsynchronized.ref 0
val string_to_int = fn () =>
let val i = !index
in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256
end
val string_to_list = fn s' =>
let val len = String.size s'
fun f () =
if !index < len then string_to_int() :: f()
else nil
in index := 0; s := s'; f ()
end
val string_to_pairlist = fn (conv_key,conv_entry) =>
let fun f () =
case string_to_int()
of 0 => EMPTY
| n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f())
in f
end
val string_to_pairlist_default = fn (conv_key,conv_entry) =>
let val conv_row = string_to_pairlist(conv_key,conv_entry)
in fn () =>
let val default = conv_entry(string_to_int())
val row = conv_row()
in (row,default)
end
end
val string_to_table = fn (convert_row,s') =>
let val len = String.size s'
fun f ()=
if !index < len then convert_row() :: f()
else nil
in (s := s'; index := 0; f ())
end
local
val memo = Array.array(numstates+numrules,ERROR)
val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1))
fun f i =
if i=numstates then g i
else (Array.update(memo,i,SHIFT (STATE i)); f (i+1))
in f 0 handle General.Subscript => ()
end
in
val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2))
end
val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT))
val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows)
val actionRowNumbers = string_to_list actionRowNumbers
val actionT = let val actionRowLookUp=
let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end
in Array.fromList(List.map actionRowLookUp actionRowNumbers)
end
in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules,
numStates=numstates,initialState=STATE 0}
end
end
local open Header in
type pos = ( int * int * int )
type arg = unit
structure MlyValue =
struct
datatype svalue = VOID | ntVOID of unit -> unit
| OF of unit -> (string) | STAR of unit -> (string)
| INTEGER_LITERAL of unit -> (string)
| UNDERSCORE of unit -> (string)
| LOWER_STRING_LITERAL of unit -> (string)
| UPPER_STRING_LITERAL of unit -> (string)
| STRING_LITERAL of unit -> (string)
| TRANSACTIONS of unit -> (string) | ANALYSIS of unit -> (string)
| ARROW of unit -> (string) | SETS of unit -> (string)
| TYPES of unit -> (string) | equal of unit -> (string)
| QUESTION of unit -> (string) | slash of unit -> (string)
| ATTACK of unit -> (string) | NEW of unit -> (string)
| DELETE of unit -> (string) | INSERT of unit -> (string)
| NOTIN of unit -> (string) | IN of unit -> (string)
| SEND of unit -> (string) | RECEIVE of unit -> (string)
| PRIVATE of unit -> (string) | PUBLIC of unit -> (string)
| FUNCTIONS of unit -> (string) | Sets of unit -> (string)
| TBETWEEN of unit -> (string) | TSECRET of unit -> (string)
| ON of unit -> (string) | WEAKLY of unit -> (string)
| AUTHENTICATES of unit -> (string) | GOALS of unit -> (string)
| ABSTRACTION of unit -> (string) | ACTIONS of unit -> (string)
| WHERE of unit -> (string) | KNOWLEDGE of unit -> (string)
| PROTOCOL of unit -> (string) | UNION of unit -> (string)
| CLOSESQB of unit -> (string) | OPENSQB of unit -> (string)
| COMMA of unit -> (string) | DOT of unit -> (string)
| EXCLAM of unit -> (string) | UNEQUAL of unit -> (string)
| PERCENT of unit -> (string) | FSECCH of unit -> (string)
| FAUTHCH of unit -> (string) | INSECCH of unit -> (string)
| CONFCH of unit -> (string) | AUTHCH of unit -> (string)
| SECCH of unit -> (string) | SEMICOLON of unit -> (string)
| COLON of unit -> (string) | CLOSESCRYPT of unit -> (string)
| OPENSCRYPT of unit -> (string) | CLOSEB of unit -> (string)
| OPENB of unit -> (string) | CLOSEP of unit -> (string)
| OPENP of unit -> (string)
| parameters of unit -> ( ( string * string ) list)
| parameter of unit -> (string*string) | typ of unit -> (string)
| transaction of unit -> (TracProtocol.transaction_name)
| ineqs of unit -> ( ( string * string ) list)
| ineq of unit -> (string*string) | ineq_aux of unit -> (string)
| actions of unit -> ( ( TracProtocol.prot_label * TracProtocol.action ) list)
| action of unit -> (TracProtocol.prot_label*TracProtocol.action)
| setexp of unit -> (string*Trac_Term.Msg list)
| msgs of unit -> (Trac_Term.Msg list)
| msg of unit -> (Trac_Term.Msg) | result of unit -> (string list)
| keys of unit -> (Trac_Term.Msg list)
| head_params of unit -> (string list)
| head of unit -> (string*string list)
| rule of unit -> (TracProtocol.ruleT)
| transaction_spec of unit -> (TracProtocol.transaction list)
| transaction_spec_head of unit -> (string option)
| analysis_spec of unit -> (TracProtocol.anaT)
| pub_fun_spec of unit -> (TracProtocol.funT list)
| priv_fun_spec of unit -> (TracProtocol.funT list)
| fun_spec of unit -> (TracProtocol.funT)
| fun_specs of unit -> (TracProtocol.funT list)
| priv_or_pub_fun_spec of unit -> (TracProtocol.fun_spec)
| set_spec of unit -> (TracProtocol.set_spec)
| set_specs of unit -> (TracProtocol.set_spec list)
| lidents of unit -> (string list)
| uidents of unit -> (string list)
| idents of unit -> (string list)
| type_specs of unit -> ( ( string * TracProtocol.type_spec_elem ) list)
| type_spec of unit -> ( ( string * TracProtocol.type_spec_elem ) )
| type_union of unit -> ( ( string list ) )
| protocol_spec of unit -> (TracProtocol.protocol)
| trac_protocol of unit -> (TracProtocol.protocol)
| ident of unit -> (string) | lident of unit -> (string)
| uident of unit -> (string) | arity of unit -> (string)
| name of unit -> (string)
| START of unit -> (TracProtocol.protocol)
end
type svalue = MlyValue.svalue
type result = TracProtocol.protocol
end
structure EC=
struct
open LrTable
infix 5 $$
fun x $$ y = y::x
val is_keyword =
fn _ => false
val preferred_change : (term list * term list) list =
nil
val noShift =
fn (T 0) => true | _ => false
val showTerminal =
fn (T 0) => "EOF"
| (T 1) => "OPENP"
| (T 2) => "CLOSEP"
| (T 3) => "OPENB"
| (T 4) => "CLOSEB"
| (T 5) => "OPENSCRYPT"
| (T 6) => "CLOSESCRYPT"
| (T 7) => "COLON"
| (T 8) => "SEMICOLON"
| (T 9) => "SECCH"
| (T 10) => "AUTHCH"
| (T 11) => "CONFCH"
| (T 12) => "INSECCH"
| (T 13) => "FAUTHCH"
| (T 14) => "FSECCH"
| (T 15) => "PERCENT"
| (T 16) => "UNEQUAL"
| (T 17) => "EXCLAM"
| (T 18) => "DOT"
| (T 19) => "COMMA"
| (T 20) => "OPENSQB"
| (T 21) => "CLOSESQB"
| (T 22) => "UNION"
| (T 23) => "PROTOCOL"
| (T 24) => "KNOWLEDGE"
| (T 25) => "WHERE"
| (T 26) => "ACTIONS"
| (T 27) => "ABSTRACTION"
| (T 28) => "GOALS"
| (T 29) => "AUTHENTICATES"
| (T 30) => "WEAKLY"
| (T 31) => "ON"
| (T 32) => "TSECRET"
| (T 33) => "TBETWEEN"
| (T 34) => "Sets"
| (T 35) => "FUNCTIONS"
| (T 36) => "PUBLIC"
| (T 37) => "PRIVATE"
| (T 38) => "RECEIVE"
| (T 39) => "SEND"
| (T 40) => "IN"
| (T 41) => "NOTIN"
| (T 42) => "INSERT"
| (T 43) => "DELETE"
| (T 44) => "NEW"
| (T 45) => "ATTACK"
| (T 46) => "slash"
| (T 47) => "QUESTION"
| (T 48) => "equal"
| (T 49) => "TYPES"
| (T 50) => "SETS"
| (T 51) => "ARROW"
| (T 52) => "ANALYSIS"
| (T 53) => "TRANSACTIONS"
| (T 54) => "STRING_LITERAL"
| (T 55) => "UPPER_STRING_LITERAL"
| (T 56) => "LOWER_STRING_LITERAL"
| (T 57) => "UNDERSCORE"
| (T 58) => "INTEGER_LITERAL"
| (T 59) => "STAR"
| (T 60) => "OF"
| _ => "bogus-term"
local open Header in
val errtermvalue=
fn _ => MlyValue.VOID
end
val terms : term list = nil
$$ (T 0)end
structure Actions =
struct
exception mlyAction of int
local open Header in
val actions =
fn (i392,defaultPos,stack,
(()):arg) =>
case (i392,stack)
of ( 0, ( ( _, ( MlyValue.trac_protocol trac_protocol1,
trac_protocol1left, trac_protocol1right)) :: rest671)) => let val
result = MlyValue.START (fn _ => let val (trac_protocol as
trac_protocol1) = trac_protocol1 ()
in (trac_protocol)
end)
in ( LrTable.NT 0, ( result, trac_protocol1left, trac_protocol1right)
, rest671)
end
| ( 1, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.name name1, _, _)) :: ( _, (
MlyValue.COLON COLON1, _, _)) :: ( _, ( MlyValue.PROTOCOL PROTOCOL1,
PROTOCOL1left, _)) :: rest671)) => let val result =
MlyValue.trac_protocol (fn _ => let val PROTOCOL1 = PROTOCOL1 ()
val COLON1 = COLON1 ()
val (name as name1) = name1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (TracProtocol.update_name protocol_spec name)
end)
in ( LrTable.NT 6, ( result, PROTOCOL1left, protocol_spec1right),
rest671)
end
| ( 2, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.type_specs type_specs1, _, _)
) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: ( _, ( MlyValue.TYPES
TYPES1, TYPES1left, _)) :: rest671)) => let val result =
MlyValue.protocol_spec (fn _ => let val TYPES1 = TYPES1 ()
val COLON1 = COLON1 ()
val (type_specs as type_specs1) = type_specs1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (TracProtocol.update_type_spec protocol_spec type_specs)
end)
in ( LrTable.NT 7, ( result, TYPES1left, protocol_spec1right),
rest671)
end
| ( 3, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.set_specs set_specs1, _, _))
:: ( _, ( MlyValue.COLON COLON1, _, _)) :: ( _, ( MlyValue.SETS SETS1
, SETS1left, _)) :: rest671)) => let val result =
MlyValue.protocol_spec (fn _ => let val SETS1 = SETS1 ()
val COLON1 = COLON1 ()
val (set_specs as set_specs1) = set_specs1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (TracProtocol.update_sets protocol_spec set_specs)
end)
in ( LrTable.NT 7, ( result, SETS1left, protocol_spec1right), rest671
)
end
| ( 4, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.priv_or_pub_fun_spec
priv_or_pub_fun_spec1, _, _)) :: ( _, ( MlyValue.COLON COLON1, _, _))
:: ( _, ( MlyValue.FUNCTIONS FUNCTIONS1, FUNCTIONS1left, _)) ::
rest671)) => let val result = MlyValue.protocol_spec (fn _ => let
val FUNCTIONS1 = FUNCTIONS1 ()
val COLON1 = COLON1 ()
val (priv_or_pub_fun_spec as priv_or_pub_fun_spec1) =
priv_or_pub_fun_spec1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (
TracProtocol.update_functions protocol_spec (SOME priv_or_pub_fun_spec)
)
end)
in ( LrTable.NT 7, ( result, FUNCTIONS1left, protocol_spec1right),
rest671)
end
| ( 5, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.analysis_spec analysis_spec1,
_, _)) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: ( _, (
MlyValue.ANALYSIS ANALYSIS1, ANALYSIS1left, _)) :: rest671)) => let
val result = MlyValue.protocol_spec (fn _ => let val ANALYSIS1 =
ANALYSIS1 ()
val COLON1 = COLON1 ()
val (analysis_spec as analysis_spec1) = analysis_spec1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (TracProtocol.update_analysis protocol_spec analysis_spec)
end)
in ( LrTable.NT 7, ( result, ANALYSIS1left, protocol_spec1right),
rest671)
end
| ( 6, ( ( _, ( MlyValue.protocol_spec protocol_spec1, _,
protocol_spec1right)) :: ( _, ( MlyValue.transaction_spec
transaction_spec1, _, _)) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: (
_, ( MlyValue.transaction_spec_head transaction_spec_head1,
transaction_spec_head1left, _)) :: rest671)) => let val result =
MlyValue.protocol_spec (fn _ => let val (transaction_spec_head as
transaction_spec_head1) = transaction_spec_head1 ()
val COLON1 = COLON1 ()
val (transaction_spec as transaction_spec1) = transaction_spec1 ()
val (protocol_spec as protocol_spec1) = protocol_spec1 ()
in (
TracProtocol.update_transactions transaction_spec_head protocol_spec transaction_spec
)
end)
in ( LrTable.NT 7, ( result, transaction_spec_head1left,
protocol_spec1right), rest671)
end
| ( 7, ( rest671)) => let val result = MlyValue.protocol_spec (fn _
=> (TracProtocol.empty))
in ( LrTable.NT 7, ( result, defaultPos, defaultPos), rest671)
end
| ( 8, ( ( _, ( MlyValue.ident ident1, ident1left, ident1right)) ::
rest671)) => let val result = MlyValue.type_union (fn _ => let val (
ident as ident1) = ident1 ()
in ([ident])
end)
in ( LrTable.NT 8, ( result, ident1left, ident1right), rest671)
end
| ( 9, ( ( _, ( MlyValue.type_union type_union1, _, type_union1right)
) :: ( _, ( MlyValue.UNION UNION1, _, _)) :: ( _, ( MlyValue.ident
ident1, ident1left, _)) :: rest671)) => let val result =
MlyValue.type_union (fn _ => let val (ident as ident1) = ident1 ()
val UNION1 = UNION1 ()
val (type_union as type_union1) = type_union1 ()
in (ident::type_union)
end)
in ( LrTable.NT 8, ( result, ident1left, type_union1right), rest671)
end
| ( 10, ( ( _, ( MlyValue.type_spec type_spec1, type_spec1left,
type_spec1right)) :: rest671)) => let val result =
MlyValue.type_specs (fn _ => let val (type_spec as type_spec1) =
type_spec1 ()
in ([type_spec])
end)
in ( LrTable.NT 10, ( result, type_spec1left, type_spec1right),
rest671)
end
| ( 11, ( ( _, ( MlyValue.type_specs type_specs1, _, type_specs1right
)) :: ( _, ( MlyValue.type_spec type_spec1, type_spec1left, _)) ::
rest671)) => let val result = MlyValue.type_specs (fn _ => let val (
type_spec as type_spec1) = type_spec1 ()
val (type_specs as type_specs1) = type_specs1 ()
in (type_spec::type_specs)
end)
in ( LrTable.NT 10, ( result, type_spec1left, type_specs1right),
rest671)
end
| ( 12, ( ( _, ( MlyValue.CLOSEB CLOSEB1, _, CLOSEB1right)) :: ( _, (
MlyValue.lidents lidents1, _, _)) :: ( _, ( MlyValue.OPENB OPENB1, _,
_)) :: ( _, ( MlyValue.equal equal1, _, _)) :: ( _, ( MlyValue.ident
ident1, ident1left, _)) :: rest671)) => let val result =
MlyValue.type_spec (fn _ => let val (ident as ident1) = ident1 ()
val equal1 = equal1 ()
val OPENB1 = OPENB1 ()
val (lidents as lidents1) = lidents1 ()
val CLOSEB1 = CLOSEB1 ()
in ((ident, TracProtocol.Consts lidents))
end)
in ( LrTable.NT 9, ( result, ident1left, CLOSEB1right), rest671)
end
| ( 13, ( ( _, ( MlyValue.type_union type_union1, _, type_union1right
)) :: ( _, ( MlyValue.equal equal1, _, _)) :: ( _, ( MlyValue.ident
ident1, ident1left, _)) :: rest671)) => let val result =
MlyValue.type_spec (fn _ => let val (ident as ident1) = ident1 ()
val equal1 = equal1 ()
val (type_union as type_union1) = type_union1 ()
in ((ident, TracProtocol.Union type_union))
end)
in ( LrTable.NT 9, ( result, ident1left, type_union1right), rest671)
end
| ( 14, ( ( _, ( MlyValue.set_spec set_spec1, set_spec1left,
set_spec1right)) :: rest671)) => let val result = MlyValue.set_specs
(fn _ => let val (set_spec as set_spec1) = set_spec1 ()
in ([set_spec])
end)
in ( LrTable.NT 14, ( result, set_spec1left, set_spec1right), rest671
)
end
| ( 15, ( ( _, ( MlyValue.set_specs set_specs1, _, set_specs1right))
:: ( _, ( MlyValue.set_spec set_spec1, set_spec1left, _)) :: rest671)
) => let val result = MlyValue.set_specs (fn _ => let val (set_spec
as set_spec1) = set_spec1 ()
val (set_specs as set_specs1) = set_specs1 ()
in (set_spec::set_specs)
end)
in ( LrTable.NT 14, ( result, set_spec1left, set_specs1right),
rest671)
end
| ( 16, ( ( _, ( MlyValue.arity arity1, _, arity1right)) :: ( _, (
MlyValue.slash slash1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.set_spec
(fn _ => let val (ident as ident1) = ident1 ()
val slash1 = slash1 ()
val (arity as arity1) = arity1 ()
in ((ident, arity))
end)
in ( LrTable.NT 15, ( result, ident1left, arity1right), rest671)
end
| ( 17, ( ( _, ( MlyValue.priv_or_pub_fun_spec priv_or_pub_fun_spec1,
_, priv_or_pub_fun_spec1right)) :: ( _, ( MlyValue.pub_fun_spec
pub_fun_spec1, pub_fun_spec1left, _)) :: rest671)) => let val result
= MlyValue.priv_or_pub_fun_spec (fn _ => let val (pub_fun_spec as
pub_fun_spec1) = pub_fun_spec1 ()
val (priv_or_pub_fun_spec as priv_or_pub_fun_spec1) =
priv_or_pub_fun_spec1 ()
in (TracProtocol.update_fun_public priv_or_pub_fun_spec pub_fun_spec)
end)
in ( LrTable.NT 16, ( result, pub_fun_spec1left,
priv_or_pub_fun_spec1right), rest671)
end
| ( 18, ( ( _, ( MlyValue.priv_or_pub_fun_spec priv_or_pub_fun_spec1,
_, priv_or_pub_fun_spec1right)) :: ( _, ( MlyValue.priv_fun_spec
priv_fun_spec1, priv_fun_spec1left, _)) :: rest671)) => let val
result = MlyValue.priv_or_pub_fun_spec (fn _ => let val (
priv_fun_spec as priv_fun_spec1) = priv_fun_spec1 ()
val (priv_or_pub_fun_spec as priv_or_pub_fun_spec1) =
priv_or_pub_fun_spec1 ()
in (
TracProtocol.update_fun_private priv_or_pub_fun_spec priv_fun_spec)
end)
in ( LrTable.NT 16, ( result, priv_fun_spec1left,
priv_or_pub_fun_spec1right), rest671)
end
| ( 19, ( rest671)) => let val result =
MlyValue.priv_or_pub_fun_spec (fn _ => (TracProtocol.fun_empty))
in ( LrTable.NT 16, ( result, defaultPos, defaultPos), rest671)
end
| ( 20, ( ( _, ( MlyValue.fun_specs fun_specs1, _, fun_specs1right))
:: ( _, ( MlyValue.PUBLIC PUBLIC1, PUBLIC1left, _)) :: rest671)) =>
let val result = MlyValue.pub_fun_spec (fn _ => let val PUBLIC1 =
PUBLIC1 ()
val (fun_specs as fun_specs1) = fun_specs1 ()
in (fun_specs)
end)
in ( LrTable.NT 20, ( result, PUBLIC1left, fun_specs1right), rest671)
end
| ( 21, ( ( _, ( MlyValue.fun_specs fun_specs1, _, fun_specs1right))
:: ( _, ( MlyValue.PRIVATE PRIVATE1, PRIVATE1left, _)) :: rest671))
=> let val result = MlyValue.priv_fun_spec (fn _ => let val
PRIVATE1 = PRIVATE1 ()
val (fun_specs as fun_specs1) = fun_specs1 ()
in (fun_specs)
end)
in ( LrTable.NT 19, ( result, PRIVATE1left, fun_specs1right), rest671
)
end
| ( 22, ( ( _, ( MlyValue.fun_spec fun_spec1, fun_spec1left,
fun_spec1right)) :: rest671)) => let val result = MlyValue.fun_specs
(fn _ => let val (fun_spec as fun_spec1) = fun_spec1 ()
in ([fun_spec])
end)
in ( LrTable.NT 17, ( result, fun_spec1left, fun_spec1right), rest671
)
end
| ( 23, ( ( _, ( MlyValue.fun_specs fun_specs1, _, fun_specs1right))
:: ( _, ( MlyValue.fun_spec fun_spec1, fun_spec1left, _)) :: rest671)
) => let val result = MlyValue.fun_specs (fn _ => let val (fun_spec
as fun_spec1) = fun_spec1 ()
val (fun_specs as fun_specs1) = fun_specs1 ()
in (fun_spec::fun_specs)
end)
in ( LrTable.NT 17, ( result, fun_spec1left, fun_specs1right),
rest671)
end
| ( 24, ( ( _, ( MlyValue.arity arity1, _, arity1right)) :: ( _, (
MlyValue.slash slash1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.fun_spec
(fn _ => let val (ident as ident1) = ident1 ()
val slash1 = slash1 ()
val (arity as arity1) = arity1 ()
in ((ident, arity))
end)
in ( LrTable.NT 18, ( result, ident1left, arity1right), rest671)
end
| ( 25, ( ( _, ( MlyValue.rule rule1, rule1left, rule1right)) ::
rest671)) => let val result = MlyValue.analysis_spec (fn _ => let
val (rule as rule1) = rule1 ()
in ([rule])
end)
in ( LrTable.NT 21, ( result, rule1left, rule1right), rest671)
end
| ( 26, ( ( _, ( MlyValue.analysis_spec analysis_spec1, _,
analysis_spec1right)) :: ( _, ( MlyValue.rule rule1, rule1left, _)) ::
rest671)) => let val result = MlyValue.analysis_spec (fn _ => let
val (rule as rule1) = rule1 ()
val (analysis_spec as analysis_spec1) = analysis_spec1 ()
in (rule::analysis_spec)
end)
in ( LrTable.NT 21, ( result, rule1left, analysis_spec1right),
rest671)
end
| ( 27, ( ( _, ( MlyValue.result result1, _, result1right)) :: ( _, (
MlyValue.ARROW ARROW1, _, _)) :: ( _, ( MlyValue.head head1,
head1left, _)) :: rest671)) => let val result = MlyValue.rule (fn _
=> let val (head as head1) = head1 ()
val ARROW1 = ARROW1 ()
val (result as result1) = result1 ()
in ((head,[],result))
end)
in ( LrTable.NT 24, ( result, head1left, result1right), rest671)
end
| ( 28, ( ( _, ( MlyValue.result result1, _, result1right)) :: ( _, (
MlyValue.ARROW ARROW1, _, _)) :: ( _, ( MlyValue.keys keys1, _, _))
:: ( _, ( MlyValue.QUESTION QUESTION1, _, _)) :: ( _, ( MlyValue.head
head1, head1left, _)) :: rest671)) => let val result = MlyValue.rule
(fn _ => let val (head as head1) = head1 ()
val QUESTION1 = QUESTION1 ()
val (keys as keys1) = keys1 ()
val ARROW1 = ARROW1 ()
val (result as result1) = result1 ()
in ((head,keys,result))
end)
in ( LrTable.NT 24, ( result, head1left, result1right), rest671)
end
| ( 29, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.head_params head_params1, _, _)) :: ( _, ( MlyValue.OPENP
OPENP1, _, _)) :: ( _, ( MlyValue.LOWER_STRING_LITERAL
LOWER_STRING_LITERAL1, LOWER_STRING_LITERAL1left, _)) :: rest671)) =>
let val result = MlyValue.head (fn _ => let val (
LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) = LOWER_STRING_LITERAL1
()
val OPENP1 = OPENP1 ()
val (head_params as head_params1) = head_params1 ()
val CLOSEP1 = CLOSEP1 ()
in ((LOWER_STRING_LITERAL,head_params))
end)
in ( LrTable.NT 25, ( result, LOWER_STRING_LITERAL1left, CLOSEP1right
), rest671)
end
| ( 30, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.head_params (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in ([UPPER_STRING_LITERAL])
end)
in ( LrTable.NT 26, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 31, ( ( _, ( MlyValue.head_params head_params1, _,
head_params1right)) :: ( _, ( MlyValue.COMMA COMMA1, _, _)) :: ( _, (
MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, _)) :: rest671)) => let val result =
MlyValue.head_params (fn _ => let val (UPPER_STRING_LITERAL as
UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1 ()
val COMMA1 = COMMA1 ()
val (head_params as head_params1) = head_params1 ()
in ([UPPER_STRING_LITERAL]@head_params)
end)
in ( LrTable.NT 26, ( result, UPPER_STRING_LITERAL1left,
head_params1right), rest671)
end
| ( 32, ( ( _, ( MlyValue.msgs msgs1, msgs1left, msgs1right)) ::
rest671)) => let val result = MlyValue.keys (fn _ => let val (msgs
as msgs1) = msgs1 ()
in (msgs)
end)
in ( LrTable.NT 27, ( result, msgs1left, msgs1right), rest671)
end
| ( 33, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.result (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in ([UPPER_STRING_LITERAL])
end)
in ( LrTable.NT 28, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 34, ( ( _, ( MlyValue.result result1, _, result1right)) :: ( _, (
MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.UPPER_STRING_LITERAL
UPPER_STRING_LITERAL1, UPPER_STRING_LITERAL1left, _)) :: rest671)) =>
let val result = MlyValue.result (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
val COMMA1 = COMMA1 ()
val (result as result1) = result1 ()
in ([UPPER_STRING_LITERAL]@result)
end)
in ( LrTable.NT 28, ( result, UPPER_STRING_LITERAL1left, result1right
), rest671)
end
| ( 35, ( ( _, ( MlyValue.TRANSACTIONS TRANSACTIONS1,
TRANSACTIONS1left, TRANSACTIONS1right)) :: rest671)) => let val
result = MlyValue.transaction_spec_head (fn _ => let val
TRANSACTIONS1 = TRANSACTIONS1 ()
in (NONE)
end)
in ( LrTable.NT 22, ( result, TRANSACTIONS1left, TRANSACTIONS1right),
rest671)
end
| ( 36, ( ( _, ( MlyValue.LOWER_STRING_LITERAL LOWER_STRING_LITERAL1,
_, LOWER_STRING_LITERAL1right)) :: ( _, ( MlyValue.OF OF1, _, _)) ::
( _, ( MlyValue.TRANSACTIONS TRANSACTIONS1, TRANSACTIONS1left, _)) ::
rest671)) => let val result = MlyValue.transaction_spec_head (fn _ =>
let val TRANSACTIONS1 = TRANSACTIONS1 ()
val OF1 = OF1 ()
val (LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) =
LOWER_STRING_LITERAL1 ()
in (SOME LOWER_STRING_LITERAL)
end)
in ( LrTable.NT 22, ( result, TRANSACTIONS1left,
LOWER_STRING_LITERAL1right), rest671)
end
| ( 37, ( ( _, ( MlyValue.DOT DOT1, _, DOT1right)) :: ( _, (
MlyValue.actions actions1, _, _)) :: ( _, ( MlyValue.transaction
transaction1, transaction1left, _)) :: rest671)) => let val result =
MlyValue.transaction_spec (fn _ => let val (transaction as
transaction1) = transaction1 ()
val (actions as actions1) = actions1 ()
val DOT1 = DOT1 ()
in ([TracProtocol.mkTransaction transaction actions])
end)
in ( LrTable.NT 23, ( result, transaction1left, DOT1right), rest671)
end
| ( 38, ( ( _, ( MlyValue.transaction_spec transaction_spec1, _,
transaction_spec1right)) :: ( _, ( MlyValue.DOT DOT1, _, _)) :: ( _, (
MlyValue.actions actions1, _, _)) :: ( _, ( MlyValue.transaction
transaction1, transaction1left, _)) :: rest671)) => let val result =
MlyValue.transaction_spec (fn _ => let val (transaction as
transaction1) = transaction1 ()
val (actions as actions1) = actions1 ()
val DOT1 = DOT1 ()
val (transaction_spec as transaction_spec1) = transaction_spec1 ()
in (
(TracProtocol.mkTransaction transaction actions)::transaction_spec)
end)
in ( LrTable.NT 23, ( result, transaction1left,
transaction_spec1right), rest671)
end
| ( 39, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
_, UPPER_STRING_LITERAL1right)) :: ( _, ( MlyValue.UNEQUAL UNEQUAL1,
UNEQUAL1left, _)) :: rest671)) => let val result = MlyValue.ineq_aux
(fn _ => let val UNEQUAL1 = UNEQUAL1 ()
val (UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) =
UPPER_STRING_LITERAL1 ()
in (UPPER_STRING_LITERAL)
end)
in ( LrTable.NT 34, ( result, UNEQUAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 40, ( ( _, ( MlyValue.ineq_aux ineq_aux1, _, ineq_aux1right)) ::
( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, _)) :: rest671)) => let val result =
MlyValue.ineq (fn _ => let val (UPPER_STRING_LITERAL as
UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1 ()
val (ineq_aux as ineq_aux1) = ineq_aux1 ()
in ((UPPER_STRING_LITERAL,ineq_aux))
end)
in ( LrTable.NT 35, ( result, UPPER_STRING_LITERAL1left,
ineq_aux1right), rest671)
end
| ( 41, ( ( _, ( MlyValue.ineq ineq1, ineq1left, ineq1right)) ::
rest671)) => let val result = MlyValue.ineqs (fn _ => let val (ineq
as ineq1) = ineq1 ()
in ([ineq])
end)
in ( LrTable.NT 36, ( result, ineq1left, ineq1right), rest671)
end
| ( 42, ( ( _, ( MlyValue.ineqs ineqs1, _, ineqs1right)) :: ( _, (
MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.ineq ineq1, ineq1left
, _)) :: rest671)) => let val result = MlyValue.ineqs (fn _ => let
val (ineq as ineq1) = ineq1 ()
val COMMA1 = COMMA1 ()
val (ineqs as ineqs1) = ineqs1 ()
in ([ineq]@ineqs)
end)
in ( LrTable.NT 36, ( result, ineq1left, ineqs1right), rest671)
end
| ( 43, ( ( _, ( MlyValue.ineqs ineqs1, _, ineqs1right)) :: ( _, (
MlyValue.WHERE WHERE1, _, _)) :: ( _, ( MlyValue.CLOSEP CLOSEP1, _, _)
) :: ( _, ( MlyValue.parameters parameters1, _, _)) :: ( _, (
MlyValue.OPENP OPENP1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.transaction
(fn _ => let val (ident as ident1) = ident1 ()
val OPENP1 = OPENP1 ()
val (parameters as parameters1) = parameters1 ()
val CLOSEP1 = CLOSEP1 ()
val WHERE1 = WHERE1 ()
val (ineqs as ineqs1) = ineqs1 ()
in ((ident,parameters,ineqs))
end)
in ( LrTable.NT 37, ( result, ident1left, ineqs1right), rest671)
end
| ( 44, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.parameters parameters1, _, _)) :: ( _, ( MlyValue.OPENP
OPENP1, _, _)) :: ( _, ( MlyValue.ident ident1, ident1left, _)) ::
rest671)) => let val result = MlyValue.transaction (fn _ => let val
(ident as ident1) = ident1 ()
val OPENP1 = OPENP1 ()
val (parameters as parameters1) = parameters1 ()
val CLOSEP1 = CLOSEP1 ()
in ((ident,parameters,[]))
end)
in ( LrTable.NT 37, ( result, ident1left, CLOSEP1right), rest671)
end
| ( 45, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.OPENP OPENP1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.transaction
(fn _ => let val (ident as ident1) = ident1 ()
val OPENP1 = OPENP1 ()
val CLOSEP1 = CLOSEP1 ()
in ((ident,[],[]))
end)
in ( LrTable.NT 37, ( result, ident1left, CLOSEP1right), rest671)
end
| ( 46, ( ( _, ( MlyValue.parameter parameter1, parameter1left,
parameter1right)) :: rest671)) => let val result =
MlyValue.parameters (fn _ => let val (parameter as parameter1) =
parameter1 ()
in ([parameter])
end)
in ( LrTable.NT 40, ( result, parameter1left, parameter1right),
rest671)
end
| ( 47, ( ( _, ( MlyValue.parameters parameters1, _, parameters1right
)) :: ( _, ( MlyValue.COMMA COMMA1, _, _)) :: ( _, (
MlyValue.parameter parameter1, parameter1left, _)) :: rest671)) => let
val result = MlyValue.parameters (fn _ => let val (parameter as
parameter1) = parameter1 ()
val COMMA1 = COMMA1 ()
val (parameters as parameters1) = parameters1 ()
in (parameter::parameters)
end)
in ( LrTable.NT 40, ( result, parameter1left, parameters1right),
rest671)
end
| ( 48, ( ( _, ( MlyValue.typ typ1, _, typ1right)) :: ( _, (
MlyValue.COLON COLON1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.parameter
(fn _ => let val (ident as ident1) = ident1 ()
val COLON1 = COLON1 ()
val (typ as typ1) = typ1 ()
in ((ident, typ))
end)
in ( LrTable.NT 39, ( result, ident1left, typ1right), rest671)
end
| ( 49, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.typ (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in (UPPER_STRING_LITERAL)
end)
in ( LrTable.NT 38, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 50, ( ( _, ( MlyValue.LOWER_STRING_LITERAL LOWER_STRING_LITERAL1,
LOWER_STRING_LITERAL1left, LOWER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.typ (fn _ => let val (
LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) = LOWER_STRING_LITERAL1
()
in (LOWER_STRING_LITERAL)
end)
in ( LrTable.NT 38, ( result, LOWER_STRING_LITERAL1left,
LOWER_STRING_LITERAL1right), rest671)
end
| ( 51, ( ( _, ( MlyValue.action action1, action1left, action1right))
:: rest671)) => let val result = MlyValue.actions (fn _ => let val
(action as action1) = action1 ()
in ([action])
end)
in ( LrTable.NT 33, ( result, action1left, action1right), rest671)
end
| ( 52, ( ( _, ( MlyValue.actions actions1, _, actions1right)) :: ( _
, ( MlyValue.action action1, action1left, _)) :: rest671)) => let val
result = MlyValue.actions (fn _ => let val (action as action1) =
action1 ()
val (actions as actions1) = actions1 ()
in (action::actions)
end)
in ( LrTable.NT 33, ( result, action1left, actions1right), rest671)
end
| ( 53, ( ( _, ( MlyValue.msg msg1, _, msg1right)) :: ( _, (
MlyValue.RECEIVE RECEIVE1, RECEIVE1left, _)) :: rest671)) => let val
result = MlyValue.action (fn _ => let val (RECEIVE as RECEIVE1) =
RECEIVE1 ()
val (msg as msg1) = msg1 ()
in ((TracProtocol.LabelN,TracProtocol.RECEIVE(msg)))
end)
in ( LrTable.NT 32, ( result, RECEIVE1left, msg1right), rest671)
end
| ( 54, ( ( _, ( MlyValue.msg msg1, _, msg1right)) :: ( _, (
MlyValue.SEND SEND1, SEND1left, _)) :: rest671)) => let val result =
MlyValue.action (fn _ => let val (SEND as SEND1) = SEND1 ()
val (msg as msg1) = msg1 ()
in ((TracProtocol.LabelN,TracProtocol.SEND(msg)))
end)
in ( LrTable.NT 32, ( result, SEND1left, msg1right), rest671)
end
| ( 55, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.IN IN1, _, _)) :: ( _, ( MlyValue.msg msg1, msg1left, _)) ::
rest671)) => let val result = MlyValue.action (fn _ => let val (msg
as msg1) = msg1 ()
val (IN as IN1) = IN1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelN,TracProtocol.IN(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, msg1left, setexp1right), rest671)
end
| ( 56, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.NOTIN NOTIN1, _, _)) :: ( _, ( MlyValue.msg msg1, msg1left,
_)) :: rest671)) => let val result = MlyValue.action (fn _ => let
val (msg as msg1) = msg1 ()
val (NOTIN as NOTIN1) = NOTIN1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelN,TracProtocol.NOTIN(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, msg1left, setexp1right), rest671)
end
| ( 57, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.UNDERSCORE UNDERSCORE1, _, _)) :: ( _, ( MlyValue.OPENP
OPENP1, _, _)) :: ( _, ( MlyValue.lident lident1, _, _)) :: ( _, (
MlyValue.NOTIN NOTIN1, _, _)) :: ( _, ( MlyValue.msg msg1, msg1left, _
)) :: rest671)) => let val result = MlyValue.action (fn _ => let val
(msg as msg1) = msg1 ()
val NOTIN1 = NOTIN1 ()
val (lident as lident1) = lident1 ()
val OPENP1 = OPENP1 ()
val UNDERSCORE1 = UNDERSCORE1 ()
val CLOSEP1 = CLOSEP1 ()
in ((TracProtocol.LabelN,TracProtocol.NOTINANY(msg,lident)))
end)
in ( LrTable.NT 32, ( result, msg1left, CLOSEP1right), rest671)
end
| ( 58, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.msg msg1, _, _)) :: ( _, ( MlyValue.INSERT INSERT1,
INSERT1left, _)) :: rest671)) => let val result = MlyValue.action (fn
_ => let val (INSERT as INSERT1) = INSERT1 ()
val (msg as msg1) = msg1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelN,TracProtocol.INSERT(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, INSERT1left, setexp1right), rest671)
end
| ( 59, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.msg msg1, _, _)) :: ( _, ( MlyValue.DELETE DELETE1,
DELETE1left, _)) :: rest671)) => let val result = MlyValue.action (fn
_ => let val (DELETE as DELETE1) = DELETE1 ()
val (msg as msg1) = msg1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelN,TracProtocol.DELETE(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, DELETE1left, setexp1right), rest671)
end
| ( 60, ( ( _, ( MlyValue.uident uident1, _, uident1right)) :: ( _, (
MlyValue.NEW NEW1, NEW1left, _)) :: rest671)) => let val result =
MlyValue.action (fn _ => let val (NEW as NEW1) = NEW1 ()
val (uident as uident1) = uident1 ()
in ((TracProtocol.LabelS,TracProtocol.NEW(uident)))
end)
in ( LrTable.NT 32, ( result, NEW1left, uident1right), rest671)
end
| ( 61, ( ( _, ( MlyValue.ATTACK ATTACK1, ATTACK1left, ATTACK1right))
:: rest671)) => let val result = MlyValue.action (fn _ => let val (
ATTACK as ATTACK1) = ATTACK1 ()
in ((TracProtocol.LabelN,TracProtocol.ATTACK))
end)
in ( LrTable.NT 32, ( result, ATTACK1left, ATTACK1right), rest671)
end
| ( 62, ( ( _, ( MlyValue.msg msg1, _, msg1right)) :: ( _, (
MlyValue.RECEIVE RECEIVE1, _, _)) :: ( _, ( MlyValue.STAR STAR1,
STAR1left, _)) :: rest671)) => let val result = MlyValue.action (fn _
=> let val STAR1 = STAR1 ()
val (RECEIVE as RECEIVE1) = RECEIVE1 ()
val (msg as msg1) = msg1 ()
in ((TracProtocol.LabelS,TracProtocol.RECEIVE(msg)))
end)
in ( LrTable.NT 32, ( result, STAR1left, msg1right), rest671)
end
| ( 63, ( ( _, ( MlyValue.msg msg1, _, msg1right)) :: ( _, (
MlyValue.SEND SEND1, _, _)) :: ( _, ( MlyValue.STAR STAR1, STAR1left,
_)) :: rest671)) => let val result = MlyValue.action (fn _ => let
val STAR1 = STAR1 ()
val (SEND as SEND1) = SEND1 ()
val (msg as msg1) = msg1 ()
in ((TracProtocol.LabelS,TracProtocol.SEND(msg)))
end)
in ( LrTable.NT 32, ( result, STAR1left, msg1right), rest671)
end
| ( 64, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.IN IN1, _, _)) :: ( _, ( MlyValue.msg msg1, _, _)) :: ( _, (
MlyValue.STAR STAR1, STAR1left, _)) :: rest671)) => let val result =
MlyValue.action (fn _ => let val STAR1 = STAR1 ()
val (msg as msg1) = msg1 ()
val (IN as IN1) = IN1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelS,TracProtocol.IN(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, STAR1left, setexp1right), rest671)
end
| ( 65, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.NOTIN NOTIN1, _, _)) :: ( _, ( MlyValue.msg msg1, _, _)) ::
( _, ( MlyValue.STAR STAR1, STAR1left, _)) :: rest671)) => let val
result = MlyValue.action (fn _ => let val STAR1 = STAR1 ()
val (msg as msg1) = msg1 ()
val (NOTIN as NOTIN1) = NOTIN1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelS,TracProtocol.NOTIN(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, STAR1left, setexp1right), rest671)
end
| ( 66, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.UNDERSCORE UNDERSCORE1, _, _)) :: ( _, ( MlyValue.OPENP
OPENP1, _, _)) :: ( _, ( MlyValue.lident lident1, _, _)) :: ( _, (
MlyValue.NOTIN NOTIN1, _, _)) :: ( _, ( MlyValue.msg msg1, _, _)) :: (
_, ( MlyValue.STAR STAR1, STAR1left, _)) :: rest671)) => let val
result = MlyValue.action (fn _ => let val STAR1 = STAR1 ()
val (msg as msg1) = msg1 ()
val NOTIN1 = NOTIN1 ()
val (lident as lident1) = lident1 ()
val OPENP1 = OPENP1 ()
val UNDERSCORE1 = UNDERSCORE1 ()
val CLOSEP1 = CLOSEP1 ()
in ((TracProtocol.LabelS,TracProtocol.NOTINANY(msg,lident)))
end)
in ( LrTable.NT 32, ( result, STAR1left, CLOSEP1right), rest671)
end
| ( 67, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.msg msg1, _, _)) :: ( _, ( MlyValue.INSERT INSERT1, _, _))
:: ( _, ( MlyValue.STAR STAR1, STAR1left, _)) :: rest671)) => let
val result = MlyValue.action (fn _ => let val STAR1 = STAR1 ()
val (INSERT as INSERT1) = INSERT1 ()
val (msg as msg1) = msg1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelS,TracProtocol.INSERT(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, STAR1left, setexp1right), rest671)
end
| ( 68, ( ( _, ( MlyValue.setexp setexp1, _, setexp1right)) :: ( _, (
MlyValue.msg msg1, _, _)) :: ( _, ( MlyValue.DELETE DELETE1, _, _))
:: ( _, ( MlyValue.STAR STAR1, STAR1left, _)) :: rest671)) => let
val result = MlyValue.action (fn _ => let val STAR1 = STAR1 ()
val (DELETE as DELETE1) = DELETE1 ()
val (msg as msg1) = msg1 ()
val (setexp as setexp1) = setexp1 ()
in ((TracProtocol.LabelS,TracProtocol.DELETE(msg,setexp)))
end)
in ( LrTable.NT 32, ( result, STAR1left, setexp1right), rest671)
end
| ( 69, ( ( _, ( MlyValue.lident lident1, lident1left, lident1right))
:: rest671)) => let val result = MlyValue.setexp (fn _ => let val (
lident as lident1) = lident1 ()
in ((lident,[]))
end)
in ( LrTable.NT 31, ( result, lident1left, lident1right), rest671)
end
| ( 70, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.msgs msgs1, _, _)) :: ( _, ( MlyValue.OPENP OPENP1, _, _))
:: ( _, ( MlyValue.lident lident1, lident1left, _)) :: rest671)) =>
let val result = MlyValue.setexp (fn _ => let val (lident as
lident1) = lident1 ()
val OPENP1 = OPENP1 ()
val (msgs as msgs1) = msgs1 ()
val CLOSEP1 = CLOSEP1 ()
in ((lident,msgs))
end)
in ( LrTable.NT 31, ( result, lident1left, CLOSEP1right), rest671)
end
| ( 71, ( ( _, ( MlyValue.uident uident1, uident1left, uident1right))
:: rest671)) => let val result = MlyValue.msg (fn _ => let val (
uident as uident1) = uident1 ()
in (Var uident)
end)
in ( LrTable.NT 29, ( result, uident1left, uident1right), rest671)
end
| ( 72, ( ( _, ( MlyValue.lident lident1, lident1left, lident1right))
:: rest671)) => let val result = MlyValue.msg (fn _ => let val (
lident as lident1) = lident1 ()
in (Const lident)
end)
in ( LrTable.NT 29, ( result, lident1left, lident1right), rest671)
end
| ( 73, ( ( _, ( MlyValue.CLOSEP CLOSEP1, _, CLOSEP1right)) :: ( _, (
MlyValue.msgs msgs1, _, _)) :: ( _, ( MlyValue.OPENP OPENP1, _, _))
:: ( _, ( MlyValue.lident lident1, lident1left, _)) :: rest671)) =>
let val result = MlyValue.msg (fn _ => let val (lident as lident1)
= lident1 ()
val OPENP1 = OPENP1 ()
val (msgs as msgs1) = msgs1 ()
val CLOSEP1 = CLOSEP1 ()
in (Fun (lident,msgs))
end)
in ( LrTable.NT 29, ( result, lident1left, CLOSEP1right), rest671)
end
| ( 74, ( ( _, ( MlyValue.msg msg1, msg1left, msg1right)) :: rest671)
) => let val result = MlyValue.msgs (fn _ => let val (msg as msg1) =
msg1 ()
in ([msg])
end)
in ( LrTable.NT 30, ( result, msg1left, msg1right), rest671)
end
| ( 75, ( ( _, ( MlyValue.msgs msgs1, _, msgs1right)) :: ( _, (
MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.msg msg1, msg1left, _
)) :: rest671)) => let val result = MlyValue.msgs (fn _ => let val (
msg as msg1) = msg1 ()
val COMMA1 = COMMA1 ()
val (msgs as msgs1) = msgs1 ()
in (msg::msgs)
end)
in ( LrTable.NT 30, ( result, msg1left, msgs1right), rest671)
end
| ( 76, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.name (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in (UPPER_STRING_LITERAL)
end)
in ( LrTable.NT 1, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 77, ( ( _, ( MlyValue.LOWER_STRING_LITERAL LOWER_STRING_LITERAL1,
LOWER_STRING_LITERAL1left, LOWER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.name (fn _ => let val (
LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) = LOWER_STRING_LITERAL1
()
in (LOWER_STRING_LITERAL)
end)
in ( LrTable.NT 1, ( result, LOWER_STRING_LITERAL1left,
LOWER_STRING_LITERAL1right), rest671)
end
| ( 78, ( ( _, ( MlyValue.UPPER_STRING_LITERAL UPPER_STRING_LITERAL1,
UPPER_STRING_LITERAL1left, UPPER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.uident (fn _ => let val (
UPPER_STRING_LITERAL as UPPER_STRING_LITERAL1) = UPPER_STRING_LITERAL1
()
in (UPPER_STRING_LITERAL)
end)
in ( LrTable.NT 3, ( result, UPPER_STRING_LITERAL1left,
UPPER_STRING_LITERAL1right), rest671)
end
| ( 79, ( ( _, ( MlyValue.uident uident1, uident1left, uident1right))
:: rest671)) => let val result = MlyValue.uidents (fn _ => let val
(uident as uident1) = uident1 ()
in ([uident])
end)
in ( LrTable.NT 12, ( result, uident1left, uident1right), rest671)
end
| ( 80, ( ( _, ( MlyValue.uidents uidents1, _, uidents1right)) :: ( _
, ( MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.uident uident1,
uident1left, _)) :: rest671)) => let val result = MlyValue.uidents
(fn _ => let val (uident as uident1) = uident1 ()
val COMMA1 = COMMA1 ()
val (uidents as uidents1) = uidents1 ()
in (uident::uidents)
end)
in ( LrTable.NT 12, ( result, uident1left, uidents1right), rest671)
end
| ( 81, ( ( _, ( MlyValue.LOWER_STRING_LITERAL LOWER_STRING_LITERAL1,
LOWER_STRING_LITERAL1left, LOWER_STRING_LITERAL1right)) :: rest671))
=> let val result = MlyValue.lident (fn _ => let val (
LOWER_STRING_LITERAL as LOWER_STRING_LITERAL1) = LOWER_STRING_LITERAL1
()
in (LOWER_STRING_LITERAL)
end)
in ( LrTable.NT 4, ( result, LOWER_STRING_LITERAL1left,
LOWER_STRING_LITERAL1right), rest671)
end
| ( 82, ( ( _, ( MlyValue.lident lident1, lident1left, lident1right))
:: rest671)) => let val result = MlyValue.lidents (fn _ => let val
(lident as lident1) = lident1 ()
in ([lident])
end)
in ( LrTable.NT 13, ( result, lident1left, lident1right), rest671)
end
| ( 83, ( ( _, ( MlyValue.lidents lidents1, _, lidents1right)) :: ( _
, ( MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.lident lident1,
lident1left, _)) :: rest671)) => let val result = MlyValue.lidents
(fn _ => let val (lident as lident1) = lident1 ()
val COMMA1 = COMMA1 ()
val (lidents as lidents1) = lidents1 ()
in (lident::lidents)
end)
in ( LrTable.NT 13, ( result, lident1left, lidents1right), rest671)
end
| ( 84, ( ( _, ( MlyValue.uident uident1, uident1left, uident1right))
:: rest671)) => let val result = MlyValue.ident (fn _ => let val (
uident as uident1) = uident1 ()
in (uident)
end)
in ( LrTable.NT 5, ( result, uident1left, uident1right), rest671)
end
| ( 85, ( ( _, ( MlyValue.lident lident1, lident1left, lident1right))
:: rest671)) => let val result = MlyValue.ident (fn _ => let val (
lident as lident1) = lident1 ()
in (lident)
end)
in ( LrTable.NT 5, ( result, lident1left, lident1right), rest671)
end
| ( 86, ( ( _, ( MlyValue.ident ident1, ident1left, ident1right)) ::
rest671)) => let val result = MlyValue.idents (fn _ => let val (
ident as ident1) = ident1 ()
in ([ident])
end)
in ( LrTable.NT 11, ( result, ident1left, ident1right), rest671)
end
| ( 87, ( ( _, ( MlyValue.idents idents1, _, idents1right)) :: ( _, (
MlyValue.COMMA COMMA1, _, _)) :: ( _, ( MlyValue.ident ident1,
ident1left, _)) :: rest671)) => let val result = MlyValue.idents (fn
_ => let val (ident as ident1) = ident1 ()
val COMMA1 = COMMA1 ()
val (idents as idents1) = idents1 ()
in (ident::idents)
end)
in ( LrTable.NT 11, ( result, ident1left, idents1right), rest671)
end
| ( 88, ( ( _, ( MlyValue.INTEGER_LITERAL INTEGER_LITERAL1,
INTEGER_LITERAL1left, INTEGER_LITERAL1right)) :: rest671)) => let val
result = MlyValue.arity (fn _ => let val (INTEGER_LITERAL as
INTEGER_LITERAL1) = INTEGER_LITERAL1 ()
in (INTEGER_LITERAL)
end)
in ( LrTable.NT 2, ( result, INTEGER_LITERAL1left,
INTEGER_LITERAL1right), rest671)
end
| _ => raise (mlyAction i392)
end
val void = MlyValue.VOID
val extract = fn a => (fn MlyValue.START x => x
| _ => let exception ParseInternal
in raise ParseInternal end) a ()
end
end
structure Tokens : TracTransaction_TOKENS =
struct
type svalue = ParserData.svalue
type ('a,'b) token = ('a,'b) Token.token
fun EOF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 0,(
ParserData.MlyValue.VOID,p1,p2))
fun OPENP (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 1,(
ParserData.MlyValue.OPENP (fn () => i),p1,p2))
fun CLOSEP (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 2,(
ParserData.MlyValue.CLOSEP (fn () => i),p1,p2))
fun OPENB (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 3,(
ParserData.MlyValue.OPENB (fn () => i),p1,p2))
fun CLOSEB (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 4,(
ParserData.MlyValue.CLOSEB (fn () => i),p1,p2))
fun OPENSCRYPT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 5,(
ParserData.MlyValue.OPENSCRYPT (fn () => i),p1,p2))
fun CLOSESCRYPT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 6,(
ParserData.MlyValue.CLOSESCRYPT (fn () => i),p1,p2))
fun COLON (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 7,(
ParserData.MlyValue.COLON (fn () => i),p1,p2))
fun SEMICOLON (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 8,(
ParserData.MlyValue.SEMICOLON (fn () => i),p1,p2))
fun SECCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 9,(
ParserData.MlyValue.SECCH (fn () => i),p1,p2))
fun AUTHCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 10,(
ParserData.MlyValue.AUTHCH (fn () => i),p1,p2))
fun CONFCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 11,(
ParserData.MlyValue.CONFCH (fn () => i),p1,p2))
fun INSECCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 12,(
ParserData.MlyValue.INSECCH (fn () => i),p1,p2))
fun FAUTHCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 13,(
ParserData.MlyValue.FAUTHCH (fn () => i),p1,p2))
fun FSECCH (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 14,(
ParserData.MlyValue.FSECCH (fn () => i),p1,p2))
fun PERCENT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 15,(
ParserData.MlyValue.PERCENT (fn () => i),p1,p2))
fun UNEQUAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 16,(
ParserData.MlyValue.UNEQUAL (fn () => i),p1,p2))
fun EXCLAM (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 17,(
ParserData.MlyValue.EXCLAM (fn () => i),p1,p2))
fun DOT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 18,(
ParserData.MlyValue.DOT (fn () => i),p1,p2))
fun COMMA (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 19,(
ParserData.MlyValue.COMMA (fn () => i),p1,p2))
fun OPENSQB (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 20,(
ParserData.MlyValue.OPENSQB (fn () => i),p1,p2))
fun CLOSESQB (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 21,(
ParserData.MlyValue.CLOSESQB (fn () => i),p1,p2))
fun UNION (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 22,(
ParserData.MlyValue.UNION (fn () => i),p1,p2))
fun PROTOCOL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 23,(
ParserData.MlyValue.PROTOCOL (fn () => i),p1,p2))
fun KNOWLEDGE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 24,(
ParserData.MlyValue.KNOWLEDGE (fn () => i),p1,p2))
fun WHERE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 25,(
ParserData.MlyValue.WHERE (fn () => i),p1,p2))
fun ACTIONS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 26,(
ParserData.MlyValue.ACTIONS (fn () => i),p1,p2))
fun ABSTRACTION (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 27,(
ParserData.MlyValue.ABSTRACTION (fn () => i),p1,p2))
fun GOALS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 28,(
ParserData.MlyValue.GOALS (fn () => i),p1,p2))
fun AUTHENTICATES (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 29,(
ParserData.MlyValue.AUTHENTICATES (fn () => i),p1,p2))
fun WEAKLY (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 30,(
ParserData.MlyValue.WEAKLY (fn () => i),p1,p2))
fun ON (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 31,(
ParserData.MlyValue.ON (fn () => i),p1,p2))
fun TSECRET (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 32,(
ParserData.MlyValue.TSECRET (fn () => i),p1,p2))
fun TBETWEEN (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 33,(
ParserData.MlyValue.TBETWEEN (fn () => i),p1,p2))
fun Sets (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 34,(
ParserData.MlyValue.Sets (fn () => i),p1,p2))
fun FUNCTIONS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 35,(
ParserData.MlyValue.FUNCTIONS (fn () => i),p1,p2))
fun PUBLIC (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 36,(
ParserData.MlyValue.PUBLIC (fn () => i),p1,p2))
fun PRIVATE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 37,(
ParserData.MlyValue.PRIVATE (fn () => i),p1,p2))
fun RECEIVE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 38,(
ParserData.MlyValue.RECEIVE (fn () => i),p1,p2))
fun SEND (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 39,(
ParserData.MlyValue.SEND (fn () => i),p1,p2))
fun IN (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 40,(
ParserData.MlyValue.IN (fn () => i),p1,p2))
fun NOTIN (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 41,(
ParserData.MlyValue.NOTIN (fn () => i),p1,p2))
fun INSERT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 42,(
ParserData.MlyValue.INSERT (fn () => i),p1,p2))
fun DELETE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 43,(
ParserData.MlyValue.DELETE (fn () => i),p1,p2))
fun NEW (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 44,(
ParserData.MlyValue.NEW (fn () => i),p1,p2))
fun ATTACK (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 45,(
ParserData.MlyValue.ATTACK (fn () => i),p1,p2))
fun slash (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 46,(
ParserData.MlyValue.slash (fn () => i),p1,p2))
fun QUESTION (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 47,(
ParserData.MlyValue.QUESTION (fn () => i),p1,p2))
fun equal (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 48,(
ParserData.MlyValue.equal (fn () => i),p1,p2))
fun TYPES (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 49,(
ParserData.MlyValue.TYPES (fn () => i),p1,p2))
fun SETS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 50,(
ParserData.MlyValue.SETS (fn () => i),p1,p2))
fun ARROW (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 51,(
ParserData.MlyValue.ARROW (fn () => i),p1,p2))
fun ANALYSIS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 52,(
ParserData.MlyValue.ANALYSIS (fn () => i),p1,p2))
fun TRANSACTIONS (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 53,(
ParserData.MlyValue.TRANSACTIONS (fn () => i),p1,p2))
fun STRING_LITERAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 54,(
ParserData.MlyValue.STRING_LITERAL (fn () => i),p1,p2))
fun UPPER_STRING_LITERAL (i,p1,p2) = Token.TOKEN (
ParserData.LrTable.T 55,(ParserData.MlyValue.UPPER_STRING_LITERAL
(fn () => i),p1,p2))
fun LOWER_STRING_LITERAL (i,p1,p2) = Token.TOKEN (
ParserData.LrTable.T 56,(ParserData.MlyValue.LOWER_STRING_LITERAL
(fn () => i),p1,p2))
fun UNDERSCORE (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 57,(
ParserData.MlyValue.UNDERSCORE (fn () => i),p1,p2))
fun INTEGER_LITERAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 58,(
ParserData.MlyValue.INTEGER_LITERAL (fn () => i),p1,p2))
fun STAR (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 59,(
ParserData.MlyValue.STAR (fn () => i),p1,p2))
fun OF (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 60,(
ParserData.MlyValue.OF (fn () => i),p1,p2))
end
end
Theory trac
section‹Support for the Trac Format›
theory
"trac"
imports
trac_fp_parser
trac_protocol_parser
keywords
"trac" :: thy_decl
and "trac_import" :: thy_decl
and "trac_trac" :: thy_decl
and "trac_import_trac" :: thy_decl
and "protocol_model_setup" :: thy_decl
and "protocol_security_proof" :: thy_decl
and "manual_protocol_model_setup" :: thy_decl
and "manual_protocol_security_proof" :: thy_decl
and "compute_fixpoint" :: thy_decl
and "compute_SMP" :: thy_decl
and "setup_protocol_model'" :: thy_decl
and "protocol_security_proof'" :: thy_decl
and "setup_protocol_checks" :: thy_decl
begin
ML ‹
fun protocol_model_interpretation_defs name =
let
fun f s =
(Binding.empty_atts:Attrib.binding, ((Binding.name s, NoSyn), name ^ "." ^ s))
in
(map f [
"public", "arity", "Ana", "Γ", "Γ⇩v", "timpls_transformable_to", "intruder_synth_mod_timpls",
"analyzed_closed_mod_timpls", "timpls_transformable_to'", "intruder_synth_mod_timpls'",
"analyzed_closed_mod_timpls'", "admissible_transaction_terms", "admissible_transaction",
"abs_substs_set", "abs_substs_fun", "in_trancl", "transaction_poschecks_comp",
"transaction_negchecks_comp", "transaction_check_comp", "transaction_check",
"transaction_check_pre", "transaction_check_post", "compute_fixpoint_fun'",
"compute_fixpoint_fun", "attack_notin_fixpoint", "protocol_covered_by_fixpoint",
"analyzed_fixpoint", "wellformed_protocol'", "wellformed_protocol", "wellformed_fixpoint",
"wellformed_composable_protocols", "composable_protocols"
]):string Interpretation.defines
end
fun protocol_model_interpretation_params name =
let
fun f s = name ^ "_" ^ s
in
map SOME [f "arity", "λ_. 0", f "public", f "Ana", f "Γ", "0::nat", "1::nat"]
end
fun declare_thm_attr attribute name print lthy =
let
val arg = [(Facts.named name, [[Token.make_string (attribute, Position.none)]])]
val (_, lthy') = Specification.theorems_cmd "" [(Binding.empty_atts, arg)] [] print lthy
in
lthy'
end
fun declare_def_attr attribute name = declare_thm_attr attribute (name ^ "_def")
val declare_code_eqn = declare_def_attr "code"
val declare_protocol_check = declare_def_attr "protocol_checks"
fun declare_protocol_checks print =
declare_protocol_check "attack_notin_fixpoint" print #>
declare_protocol_check "protocol_covered_by_fixpoint" print #>
declare_protocol_check "analyzed_fixpoint" print #>
declare_protocol_check "wellformed_protocol'" print #>
declare_protocol_check "wellformed_protocol" print #>
declare_protocol_check "wellformed_fixpoint" print #>
declare_protocol_check "compute_fixpoint_fun" print
fun eval_define (name, raw_t) lthy =
let
val t = Code_Evaluation.dynamic_value_strict lthy (Syntax.read_term lthy raw_t)
val arg = ((Binding.name name, NoSyn), ((Binding.name (name ^ "_def"),[]), t))
val (_, lthy') = Local_Theory.define arg lthy
in
(t, lthy')
end
fun eval_define_declare (name, raw_t) print =
eval_define (name, raw_t) ##> declare_code_eqn name print
val _ = Outer_Syntax.local_theory' @{command_keyword "compute_fixpoint"}
"evaluate and define protocol fixpoint"
(Parse.name -- Parse.name >> (fn (protocol, fixpoint) => fn print =>
snd o eval_define_declare (fixpoint, "compute_fixpoint_fun " ^ protocol) print));
val _ = Outer_Syntax.local_theory' @{command_keyword "compute_SMP"}
"evaluate and define a finite representation of the sub-message patterns of a protocol"
((Scan.optional (\<^keyword>‹[› |-- Parse.name --| \<^keyword>‹]›) "no_optimizations") --
Parse.name -- Parse.name >> (fn ((opt,protocol), smp) => fn print =>
let
val rmd = "List.remdups"
val f = "Stateful_Strands.trms_list⇩s⇩s⇩t"
val g =
"(λT. " ^ f ^ " T@map (pair' prot_fun.Pair) (Stateful_Strands.setops_list⇩s⇩s⇩t T))"
fun s trms =
"(" ^ rmd ^ " (List.concat (List.map (" ^ trms ^
" ∘ Labeled_Strands.unlabel ∘ transaction_strand) " ^ protocol ^ ")))"
val opt1 = "remove_superfluous_terms Γ"
val opt2 = "generalize_terms Γ is_Var"
val gsmp_opt =
"generalize_terms Γ (λt. is_Var t ∧ t ≠ TAtom AttackType ∧ " ^
"t ≠ TAtom SetType ∧ t ≠ TAtom OccursSecType ∧ ¬is_Atom (the_Var t))"
val smp_fun = "SMP0 Ana Γ"
fun smp_fun' opts =
"(λT. let T' = (" ^ rmd ^ " ∘ " ^ opts ^ " ∘ " ^ smp_fun ^
") T in List.map (λt. t ⋅ Typed_Model.var_rename (Typed_Model.max_var_set " ^
"(Messages.fv⇩s⇩e⇩t (set (T@T'))))) T')"
val cmd =
if opt = "no_optimizations" then smp_fun ^ " " ^ s f
else if opt = "optimized"
then smp_fun' (opt1 ^ " ∘ " ^ opt2) ^ " " ^ s f
else if opt = "GSMP"
then smp_fun' (opt1 ^ " ∘ " ^ gsmp_opt) ^ " " ^ s g
else error ("Invalid option: " ^ opt)
in
snd o eval_define_declare (smp, cmd) print
end));
val _ = Outer_Syntax.local_theory' @{command_keyword "setup_protocol_checks"}
"setup protocol checks"
(Parse.name -- Parse.name >> (fn (protocol_model, protocol_name) => fn print =>
let
val a1 = "coverage_check_intro_lemmata"
val a2 = "coverage_check_unfold_lemmata"
val a3 = "coverage_check_unfold_protocol_lemma"
in
declare_protocol_checks print #>
declare_thm_attr a1 (protocol_model ^ ".protocol_covered_by_fixpoint_intros") print #>
declare_def_attr a2 (protocol_model ^ ".protocol_covered_by_fixpoint") print #>
declare_def_attr a3 protocol_name print
end
));
val _ =
Outer_Syntax.local_theory_to_proof \<^command_keyword>‹setup_protocol_model'›
"prove interpretation of protocol model locale into global theory"
(Parse.!!! (Parse.name -- Parse_Spec.locale_expression) >> (fn (prefix,expr) => fn lthy =>
let
fun f x y z = ([(x,(y,(Expression.Positional z,[])))],[])
val (a,(b,c)) = nth (fst expr) 0
val name = fst b
val _ = case c of (Expression.Named [],[]) => () | _ => error "Invalid arguments"
val pexpr = f a b (protocol_model_interpretation_params prefix)
val pdefs = protocol_model_interpretation_defs name
in
if name = ""
then error "No name given"
else Interpretation.global_interpretation_cmd pexpr pdefs lthy
end));
val _ =
Outer_Syntax.local_theory_to_proof' \<^command_keyword>‹protocol_security_proof'›
"prove interpretation of secure protocol locale into global theory"
(Parse.!!! (Parse.name -- Parse_Spec.locale_expression) >> (fn (prefix,expr) => fn print =>
let
fun f x y z = ([(x,(y,(Expression.Positional z,[])))],[])
val (a,(b,c)) = nth (fst expr) 0
val d = case c of (Expression.Positional ps,[]) => ps | _ => error "Invalid arguments"
val pexpr = f a b (protocol_model_interpretation_params prefix@d)
in
declare_protocol_checks print #> Interpretation.global_interpretation_cmd pexpr []
end
));
›
ML‹
structure ml_isar_wrapper = struct
fun define_constant_definition (constname, trm) lthy =
let
val arg = ((Binding.name constname, NoSyn), ((Binding.name (constname^"_def"),[]), trm))
val ((_, (_ , thm)), lthy') = Local_Theory.define arg lthy
in
(thm, lthy')
end
fun define_constant_definition' (constname, trm) print lthy =
let
val arg = ((Binding.name constname, NoSyn), ((Binding.name (constname^"_def"),[]), trm))
val ((_, (_ , thm)), lthy') = Local_Theory.define arg lthy
val lthy'' = declare_code_eqn constname print lthy'
in
(thm, lthy'')
end
fun define_simple_abbrev (constname, trm) lthy =
let
val arg = ((Binding.name constname, NoSyn), trm)
val ((_, _), lthy') = Local_Theory.abbrev Syntax.mode_default arg lthy
in
lthy'
end
fun define_simple_type_synonym (name, typedecl) lthy =
let
val (_, lthy') = Typedecl.abbrev_global (Binding.name name, [], NoSyn) typedecl lthy
in
lthy'
end
fun define_simple_datatype (dt_tyargs, dt_name) constructors =
let
val options = Plugin_Name.default_filter
fun lift_c (tyargs, name) = (((Binding.empty, Binding.name name), map (fn t => (Binding.empty, t)) tyargs), NoSyn)
val c_spec = map lift_c constructors
val datatyp = ((map (fn ty => (NONE, ty)) dt_tyargs, Binding.name dt_name), NoSyn)
val dtspec =
((options,false),
[(((datatyp, c_spec), (Binding.empty, Binding.empty, Binding.empty)), [])])
in
BNF_FP_Def_Sugar.co_datatypes BNF_Util.Least_FP BNF_LFP.construct_lfp dtspec
end
fun define_simple_primrec pname precs lthy =
let
val rec_eqs = map (fn (lhs,rhs) => (((Binding.empty,[]), HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))),[],[])) precs
in
snd (BNF_LFP_Rec_Sugar.primrec false [] [(Binding.name pname, NONE, NoSyn)] rec_eqs lthy)
end
fun define_simple_fun pname precs lthy =
let
val rec_eqs = map (fn (lhs,rhs) => (((Binding.empty,[]), HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))),[],[])) precs
in
Function_Fun.add_fun [(Binding.name pname, NONE, NoSyn)] rec_eqs Function_Common.default_config lthy
end
fun prove_simple name stmt tactic lthy =
let
val thm = Goal.prove lthy [] [] stmt (fn {context, ...} => tactic context)
|> Goal.norm_result lthy
|> Goal.check_finished lthy
in
lthy |>
snd o Local_Theory.note ((Binding.name name, []), [thm])
end
fun prove_state_simple method proof_state =
Seq.the_result "error in proof state" ( (Proof.refine method proof_state))
|> Proof.global_done_proof
end
›
ML‹
structure trac_definitorial_package = struct
open Trac_Utils
val enum_constsN="enum_consts"
val setsN="sets"
val funN="fun"
val atomN="atom"
val arityN="arity"
val publicN = "public"
val gammaN = "Γ"
val anaN = "Ana"
val valN = "val"
val timpliesN = "timplies"
val occursN = "occurs"
val enumN = "enum"
val priv_fun_secN = "PrivFunSec"
val secret_typeN = "SecretType"
val enum_typeN = "EnumType"
val other_pubconsts_typeN = "PubConstType"
val types = [enum_typeN, secret_typeN]
val special_funs = ["occurs", "zero", valN, priv_fun_secN]
fun mk_listT T = Type ("List.list", [T])
val mk_setT = HOLogic.mk_setT
val boolT = HOLogic.boolT
val natT = HOLogic.natT
val mk_tupleT = HOLogic.mk_tupleT
val mk_prodT = HOLogic.mk_prodT
val mk_set = HOLogic.mk_set
val mk_list = HOLogic.mk_list
val mk_nat = HOLogic.mk_nat
val mk_eq = HOLogic.mk_eq
val mk_Trueprop = HOLogic.mk_Trueprop
val mk_tuple = HOLogic.mk_tuple
val mk_prod = HOLogic.mk_prod
fun mkN (a,b) = a^"_"^b
val info = Output.information
fun rm_special_funs sel l = list_minus (list_rm_pair sel) l special_funs
fun is_priv_fun (trac:TracProtocol.protocol) f = let
val funs = #private (Option.valOf (#function_spec trac))
in
List.exists (fn (g,n) => f = g andalso n <> "0") funs
end
fun full_name name lthy =
Local_Theory.full_name lthy (Binding.name name)
fun full_name' n (trac:TracProtocol.protocol) lthy = full_name (mkN (#name trac, n)) lthy
fun mk_prot_type name targs (trac:TracProtocol.protocol) lthy =
Term.Type (full_name' name trac lthy, targs)
val enum_constsT = mk_prot_type enum_constsN []
fun mk_enum_const a trac lthy =
Term.Const (full_name' enum_constsN trac lthy ^ "." ^ a, enum_constsT trac lthy)
val databaseT = mk_prot_type setsN []
val funT = mk_prot_type funN []
val atomT = mk_prot_type atomN []
fun messageT (trac:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_term", [funT trac lthy, atomT trac lthy, databaseT trac lthy])
fun message_funT (trac:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_fun", [funT trac lthy, atomT trac lthy, databaseT trac lthy])
fun message_varT (trac:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_var", [funT trac lthy, atomT trac lthy, databaseT trac lthy])
fun message_term_typeT (trc:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_term_type", [funT trc lthy, atomT trc lthy, databaseT trc lthy])
fun message_atomT (trac:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_atom", [atomT trac lthy])
fun messageT' varT (trac:TracProtocol.protocol) lthy =
Term.Type ("Term.term", [message_funT trac lthy, varT])
fun message_listT (trac:TracProtocol.protocol) lthy =
mk_listT (messageT trac lthy)
fun message_listT' varT (trac:TracProtocol.protocol) lthy =
mk_listT (messageT' varT trac lthy)
fun absT (trac:TracProtocol.protocol) lthy =
mk_setT (databaseT trac lthy)
fun abssT (trac:TracProtocol.protocol) lthy =
mk_setT (absT trac lthy)
val poscheckvariantT =
Term.Type ("Strands_and_Constraints.poscheckvariant", [])
val strand_labelT =
Term.Type ("Labeled_Strands.strand_label", [natT])
fun strand_stepT (trac:TracProtocol.protocol) lthy =
Term.Type ("Stateful_Strands.stateful_strand_step",
[message_funT trac lthy, message_varT trac lthy])
fun labeled_strand_stepT (trac:TracProtocol.protocol) lthy =
mk_prodT (strand_labelT, strand_stepT trac lthy)
fun prot_strandT (trac:TracProtocol.protocol) lthy =
mk_listT (labeled_strand_stepT trac lthy)
fun prot_transactionT (trac:TracProtocol.protocol) lthy =
Term.Type ("Transactions.prot_transaction",
[funT trac lthy, atomT trac lthy, databaseT trac lthy, natT])
val mk_star_label =
Term.Const ("Labeled_Strands.strand_label.LabelS", strand_labelT)
fun mk_prot_label (lbl:int) =
Term.Const ("Labeled_Strands.strand_label.LabelN", natT --> strand_labelT) $
mk_nat lbl
fun mk_labeled_step (label:term) (step:term) =
mk_prod (label, step)
fun mk_Send_step (trac:TracProtocol.protocol) lthy (label:term) (msg:term) =
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.Send",
messageT trac lthy --> strand_stepT trac lthy) $ msg)
fun mk_Receive_step (trac:TracProtocol.protocol) lthy (label:term) (msg:term) =
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.Receive",
messageT trac lthy --> strand_stepT trac lthy) $ msg)
fun mk_InSet_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) =
let
val psT = [poscheckvariantT, messageT trac lthy, messageT trac lthy]
in
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.InSet",
psT ---> strand_stepT trac lthy) $
Term.Const ("Strands_and_Constraints.poscheckvariant.Check", poscheckvariantT) $
elem $ set)
end
fun mk_NotInSet_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) =
let
val varT = message_varT trac lthy
val trm_prodT = mk_prodT (messageT trac lthy, messageT trac lthy)
val psT = [mk_listT varT, mk_listT trm_prodT, mk_listT trm_prodT]
in
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.NegChecks",
psT ---> strand_stepT trac lthy) $
mk_list varT [] $
mk_list trm_prodT [] $
mk_list trm_prodT [mk_prod (elem,set)])
end
fun mk_Inequality_step (trac:TracProtocol.protocol) lthy (label:term) (t1:term) (t2:term) =
let
val varT = message_varT trac lthy
val trm_prodT = mk_prodT (messageT trac lthy, messageT trac lthy)
val psT = [mk_listT varT, mk_listT trm_prodT, mk_listT trm_prodT]
in
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.NegChecks",
psT ---> strand_stepT trac lthy) $
mk_list varT [] $
mk_list trm_prodT [mk_prod (t1,t2)] $
mk_list trm_prodT [])
end
fun mk_Insert_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) =
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.Insert",
[messageT trac lthy, messageT trac lthy] ---> strand_stepT trac lthy) $
elem $ set)
fun mk_Delete_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) =
mk_labeled_step label
(Term.Const ("Stateful_Strands.stateful_strand_step.Delete",
[messageT trac lthy, messageT trac lthy] ---> strand_stepT trac lthy) $
elem $ set)
fun mk_Transaction (trac:TracProtocol.protocol) lthy S1 S2 S3 S4 S5 S6 =
let
val varT = message_varT trac lthy
val msgT = messageT trac lthy
val var_listT = mk_listT varT
val msg_listT = mk_listT msgT
val trT = prot_transactionT trac lthy
val stepT = labeled_strand_stepT trac lthy
val strandT = prot_strandT trac lthy
val strandsT = mk_listT strandT
val paramsT = [var_listT, strandT, strandT, strandT, strandT, strandT]
in
Term.Const ("Transactions.prot_transaction.Transaction", paramsT ---> trT) $
(if null S4 then mk_list varT []
else (Term.Const (@{const_name "map"}, [msgT --> varT, msg_listT] ---> var_listT) $
Term.Const (@{const_name "the_Var"}, msgT --> varT) $
mk_list msgT S4)) $
mk_list stepT S1 $
mk_list stepT [] $
(if null S3 then mk_list stepT S2
else (Term.Const (@{const_name "append"}, [strandT,strandT] ---> strandT) $
mk_list stepT S2 $
(Term.Const (@{const_name "concat"}, strandsT --> strandT) $ mk_list strandT S3))) $
mk_list stepT S5 $
mk_list stepT S6
end
fun get_funs (trac:TracProtocol.protocol) =
let
fun append_sec fs = fs@[(priv_fun_secN, "0")]
val filter_funs = filter (fn (_,n) => n <> "0")
val filter_consts = filter (fn (_,n) => n = "0")
fun inc_ar (s,n) = (s, Int.toString (1+Option.valOf (Int.fromString n)))
in
case (#function_spec trac) of
NONE => ([],[],[])
| SOME ({public=pub, private=priv}) =>
let
val pub_symbols = rm_special_funs fst (pub@map inc_ar (filter_funs priv))
val pub_funs = filter_funs pub_symbols
val pub_consts = filter_consts pub_symbols
val priv_consts = append_sec (rm_special_funs fst (filter_consts priv))
in
(pub_funs, pub_consts, priv_consts)
end
end
fun get_set_spec (trac:TracProtocol.protocol) =
mk_unique (map (fn (s,n) => (s,Option.valOf (Int.fromString n))) (#set_spec trac))
fun set_arity (trac:TracProtocol.protocol) s =
case List.find (fn x => fst x = s) (get_set_spec trac) of
SOME (_,n) => SOME n
| NONE => NONE
fun get_enums (trac:TracProtocol.protocol) =
mk_unique (TracProtocol.extract_Consts (#type_spec trac))
fun flatten_type_spec (trac:TracProtocol.protocol) =
let
fun find_type taus tau =
case List.find (fn x => fst x = tau) taus of
SOME x => snd x
| NONE => error ("Type " ^ tau ^ " has not been declared")
fun step taus (s,e) =
case e of
TracProtocol.Union ts =>
let
val es = map (find_type taus) ts
fun f es' = mk_unique (List.concat (map TracProtocol.the_Consts es'))
in
if List.all TracProtocol.is_Consts es
then (s,TracProtocol.Consts (f es))
else (s,TracProtocol.Union ts)
end
| c => (s,c)
fun loop taus =
let
val taus' = map (step taus) taus
in
if taus = taus'
then taus
else loop taus'
end
val flat_type_spec =
let
val x = loop (#type_spec trac)
val errpre = "Couldn't flatten the enumeration types: "
in
if List.all (fn (_,e) => TracProtocol.is_Consts e) x
then
let
val y = map (fn (s,e) => (s,TracProtocol.the_Consts e)) x
in
if List.all (not o List.null o snd) y
then y
else error (errpre ^ "does every type have at least one value?")
end
else error (errpre ^ "have all types been declared?")
end
in
flat_type_spec
end
fun is_attack_transaction (tr:TracProtocol.cTransaction) =
not (null (#attack_actions tr))
fun get_transaction_name (tr:TracProtocol.cTransaction) =
#1 (#transaction tr)
fun get_fresh_value_variables (tr:TracProtocol.cTransaction) =
map_filter (TracProtocol.maybe_the_Fresh o snd) (#fresh_actions tr)
fun get_nonfresh_value_variables (tr:TracProtocol.cTransaction) =
map fst (filter (fn x => snd x = "value") (#2 (#transaction tr)))
fun get_value_variables (tr:TracProtocol.cTransaction) =
get_nonfresh_value_variables tr@get_fresh_value_variables tr
fun get_enum_variables (tr:TracProtocol.cTransaction) =
mk_unique (filter (fn x => snd x <> "value") (#2 (#transaction tr)))
fun get_variable_restrictions (tr:TracProtocol.cTransaction) =
let
val enum_vars = get_enum_variables tr
val value_vars = get_value_variables tr
fun enum_member x = List.exists (fn y => x = fst y)
fun value_member x = List.exists (fn y => x = y)
fun aux [] = ([],[])
| aux ((a,b)::rs) =
if enum_member a enum_vars andalso enum_member b enum_vars
then let val (es,vs) = aux rs in ((a,b)::es,vs) end
else if value_member a value_vars andalso value_member b value_vars
then let val (es,vs) = aux rs in (es,(a,b)::vs) end
else error ("Ill-formed or ill-typed variable restriction: " ^ a ^ " != " ^ b)
in
aux (#3 (#transaction tr))
end
fun conv_enum_consts trac (t:Trac_Term.cMsg) =
let
open Trac_Term
val enums = get_enums trac
fun aux (cFun (f,ts)) =
if List.exists (fn x => x = f) enums
then if null ts
then cEnum f
else error ("Enum constant " ^ f ^ " should not have a parameter list")
else
cFun (f,map aux ts)
| aux (cConst c) =
if List.exists (fn x => x = c) enums
then cEnum c
else cConst c
| aux (cSet (s,ts)) = cSet (s,map aux ts)
| aux (cOccursFact bs) = cOccursFact (aux bs)
| aux t = t
in
aux t
end
fun val_to_abs_list vs =
let
open Trac_Term
fun aux t = case t of cEnum b => b | _ => error "Invalid val parameter list"
in
case vs of
[] => []
| (cConst "0"::ts) => val_to_abs_list ts
| (cFun (s,ps)::ts) => (s, map aux ps)::val_to_abs_list ts
| (cSet (s,ps)::ts) => (s, map aux ps)::val_to_abs_list ts
| _ => error "Invalid val parameter list"
end
fun val_to_abs (t:Trac_Term.cMsg) =
let
open Trac_Term
fun aux t = case t of cEnum b => b | _ => error "Invalid val parameter list"
fun val_to_abs_list [] = []
| val_to_abs_list (cConst "0"::ts) = val_to_abs_list ts
| val_to_abs_list (cFun (s,ps)::ts) = (s, map aux ps)::val_to_abs_list ts
| val_to_abs_list (cSet (s,ps)::ts) = (s, map aux ps)::val_to_abs_list ts
| val_to_abs_list _ = error "Invalid val parameter list"
in
case t of
cFun (f,ts) =>
if f = valN
then cAbs (val_to_abs_list ts)
else cFun (f,map val_to_abs ts)
| cSet (s,ts) =>
cSet (s,map val_to_abs ts)
| cOccursFact bs =>
cOccursFact (val_to_abs bs)
| t => t
end
fun occurs_enc t =
let
open Trac_Term
fun aux [cVar x] = cVar x
| aux [cAbs bs] = cAbs bs
| aux _ = error "Invalid occurs parameter list"
fun enc (cFun (f,ts)) = (
if f = occursN
then cOccursFact (aux ts)
else cFun (f,map enc ts))
| enc (cSet (s,ts)) =
cSet (s,map enc ts)
| enc (cOccursFact bs) =
cOccursFact (enc bs)
| enc t = t
in
enc t
end
fun priv_fun_enc trac (Trac_Term.cFun (f,ts)) = (
if is_priv_fun trac f andalso
(case ts of Trac_Term.cPrivFunSec::_ => false | _ => true)
then Trac_Term.cFun (f,Trac_Term.cPrivFunSec::map (priv_fun_enc trac) ts)
else Trac_Term.cFun (f,map (priv_fun_enc trac) ts))
| priv_fun_enc _ t = t
fun transform_cMsg trac =
priv_fun_enc trac o occurs_enc o val_to_abs o conv_enum_consts trac
fun check_no_vars_and_consts (fp:Trac_Term.cMsg list) =
let
open Trac_Term
fun aux (cVar _) = false
| aux (cConst _) = false
| aux (cFun (_,ts)) = List.all aux ts
| aux (cSet (_,ts)) = List.all aux ts
| aux (cOccursFact bs) = aux bs
| aux _ = true
in
if List.all aux fp
then fp
else error "There shouldn't be any cVars and cConsts at this point in the fixpoint translation"
end
fun split_fp (fp:Trac_Term.cMsg list) =
let
open Trac_Term
fun fa t = case t of cFun (s,_) => s <> timpliesN | _ => true
fun fb (t,ts) = case t of cOccursFact (cAbs bs) => bs::ts | _ => ts
fun fc (cFun (s, [cAbs bs, cAbs cs]),ts) =
if s = timpliesN
then (bs,cs)::ts
else ts
| fc (_,ts) = ts
val eq = eq_set (fn ((s,xs),(t,ys)) => s = t andalso eq_set (op =) (xs,ys))
fun eq_pairs ((a,b),(c,d)) = eq (a,c) andalso eq (b,d)
val timplies_trancl =
let
fun trans_step ts =
let
fun aux (s,t) = map (fn (_,u) => (s,u)) (filter (fn (v,_) => eq (t,v)) ts)
in
distinct eq_pairs (filter (not o eq) (ts@List.concat (map aux ts)))
end
fun loop ts =
let
val ts' = trans_step ts
in
if eq_set eq_pairs (ts,ts')
then ts
else loop ts'
end
in
loop
end
val ti = List.foldl fc [] fp
in
(filter fa fp, distinct eq (List.foldl fb [] fp@map snd ti), timplies_trancl ti)
end
fun mk_enum_substs trac (vars:(string * Trac_Term.VarType) list) =
let
open Trac_Term
val flat_type_spec = flatten_type_spec trac
val deltas =
let
fun f (s,EnumType tau) = (
case List.find (fn x => fst x = tau) flat_type_spec of
SOME x => map (fn c => (s,c)) (snd x)
| NONE => error ("Type " ^ tau ^ " was not found in the type specification"))
| f (s,_) = error ("Variable " ^ s ^ " is not of enum type")
in
list_product (map f vars)
end
in
map (fn d => map (fn (x,t) => (x,cEnum t)) d) deltas
end
fun ground_enum_variables trac (fp:Trac_Term.cMsg list) =
let
open Trac_Term
fun do_grounding t = map (fn d => subst_apply d t) (mk_enum_substs trac (fv_cMsg t))
in
List.concat (map do_grounding fp)
end
fun transform_fp trac (fp:Trac_Term.cMsg list) =
fp |> ground_enum_variables trac
|> map (transform_cMsg trac)
|> check_no_vars_and_consts
|> split_fp
fun database_to_hol (db:string * Trac_Term.cMsg list) (trac:TracProtocol.protocol) lthy =
let
open Trac_Term
val errmsg = "Invalid database parameter"
fun mkN' n = mkN (#name trac, n)
val s_prefix = full_name (mkN' setsN) lthy ^ "."
val e_prefix = full_name (mkN' enum_constsN) lthy ^ "."
val (s,es) = db
val tau = enum_constsT trac lthy
val databaseT = databaseT trac lthy
val a = Term.Const (s_prefix ^ s, map (fn _ => tau) es ---> databaseT)
fun param_to_hol (cVar (x,EnumType _)) = Term.Free (x, tau)
| param_to_hol (cVar (x,Untyped)) = Term.Free (x, tau)
| param_to_hol (cEnum e) = Term.Const (e_prefix ^ e, tau)
| param_to_hol (cConst c) = error (errmsg ^ ": cConst " ^ c)
| param_to_hol (cVar (x,ValueType)) = error (errmsg ^ ": cVar (" ^ x ^ ",ValueType)")
| param_to_hol _ = error errmsg
in
fold (fn e => fn b => b $ param_to_hol e) es a
end
fun abs_to_hol (bs:(string * string list) list) (trac:TracProtocol.protocol) lthy =
let
val databaseT = databaseT trac lthy
fun db_params_to_cEnum (a,cs) = (a, map Trac_Term.cEnum cs)
in
mk_set databaseT (map (fn db => database_to_hol (db_params_to_cEnum db) trac lthy) bs)
end
fun cMsg_to_hol (t:Trac_Term.cMsg) lbl varT var_map free_enum_var trac lthy =
let
open Trac_Term
val tT = messageT' varT trac lthy
val fT = message_funT trac lthy
val enum_constsT = enum_constsT trac lthy
val tsT = message_listT' varT trac lthy
val VarT = varT --> tT
val FunT = [fT, tsT] ---> tT
val absT = absT trac lthy
val databaseT = databaseT trac lthy
val AbsT = absT --> fT
val funT = funT trac lthy
val FuT = funT --> fT
val SetT = databaseT --> fT
val enumT = enum_constsT --> funT
val VarC = Term.Const (@{const_name "Var"}, VarT)
val FunC = Term.Const (@{const_name "Fun"}, FunT)
val NilC = Term.Const (@{const_name "Nil"}, tsT)
val prot_label = mk_nat lbl
fun full_name'' n = full_name' n trac lthy
fun mk_enum_const' a = mk_enum_const a trac lthy
fun mk_prot_fun_trm f tau = Term.Const ("Transactions.prot_fun." ^ f, tau)
fun mk_enum_trm etrm =
mk_prot_fun_trm "Fu" FuT $ (Term.Const (full_name'' funN ^ "." ^ enumN, enumT) $ etrm)
fun mk_Fu_trm f =
mk_prot_fun_trm "Fu" FuT $ Term.Const (full_name'' funN ^ "." ^ f, funT)
fun c_to_h s = cMsg_to_hol s lbl varT var_map free_enum_var trac lthy
fun c_list_to_h ts = mk_list tT (map c_to_h ts)
in
case t of
cVar x =>
if free_enum_var x
then FunC $ mk_enum_trm (Term.Free (fst x, enum_constsT)) $ NilC
else VarC $ var_map x
| cConst f =>
FunC $
mk_Fu_trm f $
NilC
| cFun (f,ts) =>
FunC $
mk_Fu_trm f $
c_list_to_h ts
| cSet (s,ts) =>
FunC $
(mk_prot_fun_trm "Set" SetT $ database_to_hol (s,ts) trac lthy) $
NilC
| cAttack =>
FunC $
(mk_prot_fun_trm "Attack" (natT --> fT) $ prot_label) $
NilC
| cAbs bs =>
FunC $
(mk_prot_fun_trm "Abs" AbsT $ abs_to_hol bs trac lthy) $
NilC
| cOccursFact bs =>
FunC $
mk_prot_fun_trm "OccursFact" fT $
mk_list tT [
FunC $ mk_prot_fun_trm "OccursSec" fT $ NilC,
c_to_h bs]
| cPrivFunSec =>
FunC $
mk_Fu_trm priv_fun_secN $
NilC
| cEnum a =>
FunC $
mk_enum_trm (mk_enum_const' a) $
NilC
end
fun ground_cMsg_to_hol t lbl trac lthy =
cMsg_to_hol t lbl (message_varT trac lthy) (fn _ => error "Term not ground")
(fn _ => false) trac lthy
fun ana_cMsg_to_hol inc_vars t (ana_var_map:string list) =
let
open Trac_Term
fun var_map (x,Untyped) = (
case list_find (fn y => x = y) ana_var_map of
SOME (_,n) => if inc_vars then mk_nat (1+n) else mk_nat n
| NONE => error ("Analysis variable " ^ x ^ " not found"))
| var_map _ = error "Analysis variables must be untyped"
val lbl = 0
in
cMsg_to_hol t lbl natT var_map (fn _ => false)
end
fun transaction_cMsg_to_hol t lbl (transaction_var_map:string list) trac lthy =
let
open Trac_Term
val varT = message_varT trac lthy
val atomT = message_atomT trac lthy
val term_typeT = message_term_typeT trac lthy
fun TAtom_Value_var n =
let
val a = Term.Const (@{const_name "Var"}, atomT --> term_typeT) $
Term.Const ("Transactions.prot_atom.Value", atomT)
in
HOLogic.mk_prod (a, mk_nat n)
end
fun var_map_err_prefix x =
"Transaction variable " ^ x ^ " should be value typed but is actually "
fun var_map (x,ValueType) = (
case list_find (fn y => x = y) transaction_var_map of
SOME (_,n) => TAtom_Value_var n
| NONE => error ("Transaction variable " ^ x ^ " not found"))
| var_map (x,EnumType e) = error (var_map_err_prefix x ^ "of enum type " ^ e)
| var_map (x,Untyped) = error (var_map_err_prefix x ^ "untyped")
in
cMsg_to_hol t lbl varT var_map (fn (_,t) => case t of EnumType _ => true | _ => false)
trac lthy
end
fun fp_triple_to_hol (fp,occ,ti) trac lthy =
let
val prot_label = 0
val tau_abs = absT trac lthy
val tau_fp_elem = messageT trac lthy
val tau_occ_elem = tau_abs
val tau_ti_elem = mk_prodT (tau_abs, tau_abs)
fun a_to_h bs = abs_to_hol bs trac lthy
fun c_to_h t = ground_cMsg_to_hol t prot_label trac lthy
val fp' = mk_list tau_fp_elem (map c_to_h fp)
val occ' = mk_list tau_occ_elem (map a_to_h occ)
val ti' = mk_list tau_ti_elem (map (mk_prod o map_prod a_to_h) ti)
in
mk_tuple [fp', occ', ti']
end
fun abstract_over_enum_vars enum_vars enum_ineqs trm flat_type_spec trac lthy =
let
val enum_constsT = enum_constsT trac lthy
fun enumlistelemT n = mk_tupleT (replicate n enum_constsT)
fun enumlistT n = mk_listT (enumlistelemT n)
fun mk_enum_const' a = mk_enum_const a trac lthy
fun absfreeprod xs trm =
let
val tau = enum_constsT
val tau_out = Term.fastype_of trm
fun absfree' x = absfree (x,enum_constsT)
fun aux _ [] = trm
| aux _ [x] = absfree' x trm
| aux len (x::y::xs) =
Term.Const (@{const_name "case_prod"},
[[tau,mk_tupleT (replicate (len-1) tau)] ---> tau_out,
mk_tupleT (replicate len tau)] ---> tau_out) $
absfree' x (aux (len-1) (y::xs))
in
aux (length xs) xs
end
fun mk_enum_neq (a,b) = (HOLogic.mk_not o HOLogic.mk_eq)
(Term.Free (a, enum_constsT), Term.Free (b, enum_constsT))
fun mk_enum_neqs_list [] = Term.Const (@{const_name "True"}, HOLogic.boolT)
| mk_enum_neqs_list [x] = mk_enum_neq x
| mk_enum_neqs_list (x::y::xs) = HOLogic.mk_conj (mk_enum_neq x, mk_enum_neqs_list (y::xs))
val enum_types =
let
fun aux t =
if t = ""
then get_enums trac
else case List.find (fn (s,_) => t = s) flat_type_spec of
SOME (_,cs) => cs
| NONE => error ("Not an enum type: " ^ t ^ "?")
in
map (aux o snd) enum_vars
end
val enumlist_product =
let
fun mk_enumlist ns = mk_list enum_constsT (map mk_enum_const' ns)
fun aux _ [] = mk_enumlist []
| aux _ [ns] = mk_enumlist ns
| aux len (ns::ms::elists) =
Term.Const ("List.product", [enumlistT 1, enumlistT (len-1)] ---> enumlistT len) $
mk_enumlist ns $ aux (len-1) (ms::elists)
in
aux (length enum_types) enum_types
end
val absfp = absfreeprod (map fst enum_vars) trm
val eptrm = enumlist_product
val typof = Term.fastype_of
val evseT = enumlistelemT (length enum_vars)
val evslT = enumlistT (length enum_vars)
val eneqs = absfreeprod (map fst enum_vars) (mk_enum_neqs_list enum_ineqs)
in
if null enum_vars
then mk_list (typof trm) [trm]
else if null enum_ineqs
then Term.Const(@{const_name "map"},
[typof absfp, typof eptrm] ---> mk_listT (typof trm)) $
absfp $ eptrm
else Term.Const(@{const_name "map"},
[typof absfp, typof eptrm] ---> mk_listT (typof trm)) $
absfp $ (Term.Const(@{const_name "filter"},
[evseT --> HOLogic.boolT, evslT] ---> evslT) $
eneqs $ eptrm)
end
fun mk_type_of_name lthy pname name ty_args
= Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, name))), ty_args)
fun mk_mt_list t = Term.Const (@{const_name "Nil"}, mk_listT t)
fun name_of_typ (Type (s, _)) = s
| name_of_typ (TFree _) = error "name_of_type: unexpected TFree"
| name_of_typ (TVar _ ) = error "name_of_type: unexpected TVAR"
fun prove_UNIV name typ elems thmsN lthy =
let
val rhs = mk_set typ elems
val lhs = Const("Set.UNIV",mk_setT typ)
val stmt = mk_Trueprop (mk_eq (lhs,rhs))
val fq_tname = name_of_typ typ
fun inst_and_prove_enum thy =
let
val _ = writeln("Inst enum: "^name)
val lthy = Class.instantiation ([fq_tname], [], @{sort enum}) thy
val enum_eq = Const("Pure.eq",mk_listT typ --> mk_listT typ --> propT)
$Const(@{const_name "enum_class.enum"},mk_listT typ)
$(mk_list typ elems)
val ((_, (_, enum_def')), lthy) = Specification.definition NONE [] []
((Binding.name ("enum_"^name),[]), enum_eq) lthy
val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy)
val enum_def = singleton (Proof_Context.export lthy ctxt_thy) enum_def'
val enum_all_eq = Const("Pure.eq", boolT --> boolT --> propT)
$(Const(@{const_name "enum_class.enum_all"},(typ --> boolT) --> boolT)
$Free("P",typ --> boolT))
$(Const(@{const_name "list_all"},(typ --> boolT) --> (mk_listT typ) --> boolT)
$Free("P",typ --> boolT)$(mk_list typ elems))
val ((_, (_, enum_all_def')), lthy) = Specification.definition NONE [] []
((Binding.name ("enum_all_"^name),[]), enum_all_eq) lthy
val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy)
val enum_all_def = singleton (Proof_Context.export lthy ctxt_thy) enum_all_def'
val enum_ex_eq = Const("Pure.eq", boolT --> boolT --> propT)
$(Const(@{const_name "enum_class.enum_ex"},(typ --> boolT) --> boolT)
$Free("P",typ --> boolT))
$(Const(@{const_name "list_ex"},(typ --> boolT) --> (mk_listT typ) --> boolT)
$Free("P",typ --> boolT)$(mk_list typ elems))
val ((_, (_, enum_ex_def')), lthy) = Specification.definition NONE [] []
((Binding.name ("enum_ex_"^name),[]), enum_ex_eq) lthy
val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy)
val enum_ex_def = singleton (Proof_Context.export lthy ctxt_thy) enum_ex_def'
in
Class.prove_instantiation_exit (fn ctxt =>
(Class.intro_classes_tac ctxt []) THEN
ALLGOALS (simp_tac (ctxt addsimps [Proof_Context.get_thm ctxt (name^"_UNIV"),
enum_def, enum_all_def, enum_ex_def]) )
)lthy
end
fun inst_and_prove_finite thy =
let
val lthy = Class.instantiation ([fq_tname], [], @{sort finite}) thy
in
Class.prove_instantiation_exit (fn ctxt =>
(Class.intro_classes_tac ctxt []) THEN
(simp_tac (ctxt addsimps[Proof_Context.get_thm ctxt (name^"_UNIV")])) 1) lthy
end
in
lthy
|> ml_isar_wrapper.prove_simple (name^"_UNIV") stmt
(fn c => (safe_tac c)
THEN (ALLGOALS(simp_tac c))
THEN (ALLGOALS(Metis_Tactic.metis_tac ["full_types"]
"combs" c
(map (Proof_Context.get_thm c) thmsN)))
)
|> Local_Theory.raw_theory inst_and_prove_finite
|> Local_Theory.raw_theory inst_and_prove_enum
end
fun def_types (trac:TracProtocol.protocol) lthy =
let
val pname = #name trac
val defname = mkN(pname, enum_constsN)
val _ = info(" Defining "^defname)
val tnames = get_enums trac
val types = map (fn x => ([],x)) tnames
in
([defname], ml_isar_wrapper.define_simple_datatype ([], defname) types lthy)
end
fun def_sets (trac:TracProtocol.protocol) lthy =
let
val pname = #name trac
val defname = mkN(pname, setsN)
val _ = info (" Defining "^defname)
val sspec = get_set_spec trac
val tfqn = Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN)))
val ttyp = Type(tfqn, [])
val types = map (fn (x,n) => (replicate n ttyp,x)) sspec
in
lthy
|> ml_isar_wrapper.define_simple_datatype ([], defname) types
end
fun def_funs (trac:TracProtocol.protocol) lthy =
let
val pname = #name trac
val (pub_f, pub_c, priv) = get_funs trac
val pub = pub_f@pub_c
fun def_atom lthy =
let
val def_atomname = mkN(pname, atomN)
val types =
if null pub_c
then types
else types@[other_pubconsts_typeN]
fun define_atom_dt lthy =
let
val _ = info(" Defining "^def_atomname)
in
lthy
|> ml_isar_wrapper.define_simple_datatype ([], def_atomname) (map (fn x => ([],x)) types)
end
fun prove_UNIV_atom lthy =
let
val _ = info (" Proving "^def_atomname^"_UNIV")
val thmsN = [def_atomname^".exhaust"]
val fqn = Local_Theory.full_name lthy (Binding.name (mkN(pname, atomN)))
val typ = Type(fqn, [])
in
lthy
|> prove_UNIV (def_atomname) typ (map (fn c => Const(fqn^"."^c,typ)) types) thmsN
end
in
lthy
|> define_atom_dt
|> prove_UNIV_atom
end
fun def_fun_dt lthy =
let
val def_funname = mkN(pname, funN)
val _ = info(" Defining "^def_funname)
val types = map (fn x => ([],x)) (map fst (pub@priv))
val ctyp = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), [])
in
ml_isar_wrapper.define_simple_datatype ([], def_funname) (types@[([ctyp],enumN)]) lthy
end
fun def_fun_arity lthy =
let
val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN)))
val ctyp = Type(fqn_name, [])
fun mk_rec_eq name (fname,arity) = (Free(name,ctyp --> natT)
$Const(fqn_name^"."^fname,ctyp),
mk_nat((Option.valOf o Int.fromString) arity))
val name = mkN(pname, arityN)
val _ = info(" Defining "^name)
val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), [])
in
ml_isar_wrapper.define_simple_fun name
((map (mk_rec_eq name) (pub@priv))@[
(Free(name, ctyp --> natT)
$(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')),
mk_nat(0))]) lthy
end
fun def_public lthy =
let
val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN)))
val ctyp = Type(fqn_name, [])
fun mk_rec_eq name t fname = (Free(name, ctyp --> boolT)
$Const(fqn_name^"."^fname,ctyp), t)
val name = mkN(pname, publicN)
val _ = info(" Defining "^name)
val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), [])
in
ml_isar_wrapper.define_simple_fun name
((map (mk_rec_eq name (@{term "False"})) (map fst priv))
@(map (mk_rec_eq name (@{term "True"})) (map fst pub))
@[(Free(name, ctyp --> boolT)
$(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')),
@{term "True"})]) lthy
end
fun def_gamma lthy =
let
fun optionT t = Type (@{type_name "option"}, [t])
fun mk_Some t = Const (@{const_name "Some"}, t --> optionT t)
fun mk_None t = Const (@{const_name "None"}, optionT t)
val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN)))
val ctyp = Type(fqn_name, [])
val atomFQN = Local_Theory.full_name lthy (Binding.name (mkN(pname, atomN)))
val atomT = Type(atomFQN, [])
fun mk_rec_eq name t fname = (Free(name, ctyp --> optionT atomT)
$Const(fqn_name^"."^fname,ctyp), t)
val name = mkN(pname, gammaN)
val _ = info(" Defining "^name)
val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), [])
in
ml_isar_wrapper.define_simple_fun name
((map (mk_rec_eq name ((mk_Some atomT)$(Const(atomFQN^"."^secret_typeN, atomT)))) (map fst priv))
@(map (mk_rec_eq name ((mk_Some atomT)$(Const(atomFQN^"."^other_pubconsts_typeN, atomT)))) (map fst pub_c))
@[(Free(name, ctyp --> optionT atomT)
$(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')),
(mk_Some atomT)$(Const(atomFQN^"."^enum_typeN,atomT)))]
@(map (mk_rec_eq name (mk_None atomT)) (map fst pub_f)) ) lthy
end
fun def_ana lthy = let
val pname = #name trac
val (pub_f, pub_c, priv) = get_funs trac
val pub = pub_f@pub_c
val keyT = messageT' natT trac lthy
val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN)))
val ctyp = Type(fqn_name, [])
val ana_outputT = mk_prodT (mk_listT keyT, mk_listT natT)
val default_output = mk_prod (mk_list keyT [], mk_list natT [])
fun mk_ana_output ks rs = mk_prod (mk_list keyT ks, mk_list natT rs)
fun mk_rec_eq name t fname = (Free(name, ctyp --> ana_outputT)
$Term.Const(fqn_name^"."^fname,ctyp), t)
val name = mkN(pname, anaN)
val _ = info(" Defining "^name)
val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), [])
val ana_spec =
let
val toInt = Option.valOf o Int.fromString
fun ana_arity (f,n) = (if is_priv_fun trac f then (toInt n)-1 else toInt n)
fun check_valid_arity ((f,ps),ks,rs) =
case List.find (fn g => f = fst g) pub_f of
SOME (f',n) =>
if length ps <> ana_arity (f',n)
then error ("Invalid number of parameters in the analysis rule for " ^ f ^
" (expected " ^ Int.toString (ana_arity (f',n)) ^
" but got " ^ Int.toString (length ps) ^ ")")
else ((f,ps),ks,rs)
| NONE => error (f ^ " is not a declared function symbol of arity greater than zero")
val transform_cMsg = transform_cMsg trac
val rm_special_funs = rm_special_funs (fn ((f,_),_,_) => f)
fun var_to_nat f xs x =
let
val n = snd (Option.valOf ((list_find (fn y => y = x) xs)))
in
if is_priv_fun trac f then mk_nat (1+n) else mk_nat n
end
fun c_to_h f xs t = ana_cMsg_to_hol (is_priv_fun trac f) t xs trac lthy
fun keys f ps ks = map (c_to_h f ps o transform_cMsg o Trac_Term.certifyMsg [] []) ks
fun results f ps rs = map (var_to_nat f ps) rs
fun aux ((f,ps),ks,rs) = (f, mk_ana_output (keys f ps ks) (results f ps rs))
in
map (aux o check_valid_arity) (rm_special_funs (#analysis_spec trac))
end
val other_funs =
filter (fn f => not (List.exists (fn g => f = g) (map fst ana_spec))) (map fst (pub@priv))
in
ml_isar_wrapper.define_simple_fun name
((map (fn (f,out) => mk_rec_eq name out f) ana_spec)
@(map (mk_rec_eq name default_output) other_funs)
@[(Free(name, ctyp --> ana_outputT)
$(Term.Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')),
default_output)]) lthy
end
in
lthy |> def_atom
|> def_fun_dt
|> def_fun_arity
|> def_public
|> def_gamma
|> def_ana
end
fun define_term_model (trac:TracProtocol.protocol) lthy =
let
val _ = info("Defining term model")
in
lthy |> snd o def_types trac
|> def_sets trac
|> def_funs trac
end
fun define_fixpoint fp trac print lthy =
let
val fp_name = mkN (#name trac, "fixpoint")
val _ = info("Defining fixpoint")
val _ = info(" Defining "^fp_name)
val fp_triple = transform_fp trac fp
val fp_triple_trm = fp_triple_to_hol fp_triple trac lthy
val trac = TracProtocol.update_fixed_point trac (SOME fp_triple)
in
(trac, #2 (ml_isar_wrapper.define_constant_definition' (fp_name, fp_triple_trm) print lthy))
end
fun define_protocol print ((trac:TracProtocol.protocol), lthy) = let
val _ =
if length (#transaction_spec trac) > 1
then info("Defining protocols")
else info("Defining protocol")
val pname = #name trac
val flat_type_spec = flatten_type_spec trac
val mk_Transaction = mk_Transaction trac lthy
val mk_Send = mk_Send_step trac lthy
val mk_Receive = mk_Receive_step trac lthy
val mk_InSet = mk_InSet_step trac lthy
val mk_NotInSet = mk_NotInSet_step trac lthy
val mk_Inequality = mk_Inequality_step trac lthy
val mk_Insert = mk_Insert_step trac lthy
val mk_Delete = mk_Delete_step trac lthy
val star_label = mk_star_label
val prot_label = mk_prot_label
val certify_transation = TracProtocol.certifyTransaction
fun mk_tname i (tr:TracProtocol.transaction_name) =
let
val x = #1 tr
val y = case i of NONE => x | SOME n => mkN(n, x)
val z = mkN("transaction", y)
in mkN(pname, z)
end
fun def_transaction name_prefix prot_num (transaction:TracProtocol.cTransaction) lthy = let
val defname = mk_tname name_prefix (#transaction transaction)
val _ = info(" Defining "^defname)
val receives = #receive_actions transaction
val checkssingle = #checksingle_actions transaction
val checksall = #checkall_actions transaction
val updates = #update_actions transaction
val sends = #send_actions transaction
val fresh = get_fresh_value_variables transaction
val attack_signals = #attack_actions transaction
val nonfresh_value_vars = get_nonfresh_value_variables transaction
val value_vars = get_value_variables transaction
val enum_vars = get_enum_variables transaction
val (enum_ineqs, value_ineqs) = get_variable_restrictions transaction
val transform_cMsg = transform_cMsg trac
fun c_to_h trm = transaction_cMsg_to_hol (transform_cMsg trm) prot_num value_vars trac lthy
val abstract_over_enum_vars = fn x => fn y => fn z =>
abstract_over_enum_vars x y z flat_type_spec trac lthy
fun mk_transaction_term (rcvs, chcksingle, chckall, upds, snds, frsh, atcks) =
let
open Trac_Term
fun action_filter f (lbl,a) = case f a of SOME x => SOME (lbl,x) | NONE => NONE
fun lbl_to_h (TracProtocol.LabelS) = star_label
| lbl_to_h (TracProtocol.LabelN) = prot_label prot_num
fun lbl_trm_to_h f (lbl,t) = f (lbl_to_h lbl) (c_to_h t)
val S1 = map (lbl_trm_to_h mk_Receive)
(map_filter (action_filter TracProtocol.maybe_the_Receive) rcvs)
val S2 =
let
fun aux (lbl,TracProtocol.cInequality (x,y)) =
SOME (mk_Inequality (lbl_to_h lbl) (c_to_h x) (c_to_h y))
| aux (lbl,TracProtocol.cInSet (e,s)) =
SOME (mk_InSet (lbl_to_h lbl) (c_to_h e) (c_to_h s))
| aux (lbl,TracProtocol.cNotInSet (e,s)) =
SOME (mk_NotInSet (lbl_to_h lbl) (c_to_h e) (c_to_h s))
| aux _ = NONE
in
map_filter aux chcksingle
end
val S3 =
let
fun arity s = case set_arity trac s of
SOME n => n
| NONE => error ("Not a set family: " ^ s)
fun mk_evs s = map (fn n => ("X" ^ Int.toString n, "")) (0 upto ((arity s) -1))
fun mk_trm (lbl,e,s) =
let
val ps = map (fn x => cVar (x,Untyped)) (map fst (mk_evs s))
in
mk_NotInSet (lbl_to_h lbl) (c_to_h e) (c_to_h (cSet (s,ps)))
end
fun mk_trms (lbl,(e,s)) =
abstract_over_enum_vars (mk_evs s) [] (mk_trm (lbl,e,s))
in
map mk_trms (map_filter (action_filter TracProtocol.maybe_the_NotInAny) chckall)
end
val S4 = map (c_to_h o mk_Value_cVar) frsh
val S5 =
let
fun aux (lbl,TracProtocol.cInsert (e,s)) =
SOME (mk_Insert (lbl_to_h lbl) (c_to_h e) (c_to_h s))
| aux (lbl,TracProtocol.cDelete (e,s)) =
SOME (mk_Delete (lbl_to_h lbl) (c_to_h e) (c_to_h s))
| aux _ = NONE
in
map_filter aux upds
end
val S6 =
let val snds' = map_filter (action_filter TracProtocol.maybe_the_Send) snds
in map (lbl_trm_to_h mk_Send) (snds'@map (fn (lbl,_) => (lbl,cAttack)) atcks) end
in
abstract_over_enum_vars enum_vars enum_ineqs (mk_Transaction S1 S2 S3 S4 S5 S6)
end
fun def_trm trm print lthy =
#2 (ml_isar_wrapper.define_constant_definition' (defname, trm) print lthy)
val additional_value_ineqs =
let
open Trac_Term
open TracProtocol
val poschecks = map_filter (maybe_the_InSet o snd) checkssingle
val negchecks_single = map_filter (maybe_the_NotInSet o snd) checkssingle
val negchecks_all = map_filter (maybe_the_NotInAny o snd) checksall
fun aux' (cVar (x,ValueType),s) (cVar (y,ValueType),t) =
if s = t then SOME (x,y) else NONE
| aux' _ _ = NONE
fun aux (x,cSet (s,ps)) = SOME (
map_filter (aux' (x,cSet (s,ps))) negchecks_single@
map_filter (aux' (x,s)) negchecks_all
)
| aux _ = NONE
in
List.concat (map_filter aux poschecks)
end
val all_value_ineqs = mk_unique (value_ineqs@additional_value_ineqs)
val valvarsprod =
filter (fn p => not (List.exists (fn q => p = q orelse swap p = q) all_value_ineqs))
(list_triangle_product (fn x => fn y => (x,y)) nonfresh_value_vars)
val transaction_trm0 = mk_transaction_term
(receives, checkssingle, checksall, updates, sends, fresh, attack_signals)
in
if null valvarsprod
then def_trm transaction_trm0 print lthy
else let
val partitions = list_partitions nonfresh_value_vars all_value_ineqs
val ps = filter (not o null) (map (filter (fn x => length x > 1)) partitions)
fun mk_subst ps =
let
open Trac_Term
fun aux [] = NONE
| aux (x::xs) = SOME (map (fn y => (y,cVar (x,ValueType))) xs)
in
List.concat (map_filter aux ps)
end
fun apply d =
let
val ap = TracProtocol.subst_apply_actions d
fun f (TracProtocol.cInequality (x,y)) = x <> y
| f _ = true
val checksingle' = filter (f o snd) (ap checkssingle)
in
(ap receives, checksingle', ap checksall, ap updates, ap sends, fresh, attack_signals)
end
val transaction_trms = transaction_trm0::map (mk_transaction_term o apply o mk_subst) ps
val transaction_typ = Term.fastype_of transaction_trm0
fun mk_concat_trm tau trms =
Term.Const (@{const_name "concat"}, mk_listT tau --> tau) $ mk_list tau trms
in
def_trm (mk_concat_trm transaction_typ transaction_trms) print lthy
end
end
val def_transactions =
let
val prots = map (fn (n,pr) => map (fn tr => (n,tr)) pr) (#transaction_spec trac)
val lbls = list_upto (length prots)
val lbl_prots = List.concat (map (fn i => map (fn tr => (i,tr)) (nth prots i)) lbls)
val f = fold (fn (i,(n,tr)) => def_transaction n i (certify_transation tr))
in
f lbl_prots
end
fun def_protocols lthy = let
fun mk_prot_def (name,trm) lthy =
let val _ = info(" Defining "^name)
in #2 (ml_isar_wrapper.define_constant_definition' (name,trm) print lthy)
end
val prots = #transaction_spec trac
val num_prots = length prots
val pdefname = mkN(pname, "protocol")
fun mk_tnames i =
let
val trs = case nth prots i of (j,prot) => map (fn tr => (j,tr)) prot
in map (fn (j,s) => full_name (mk_tname j (#transaction s)) lthy) trs
end
val tnames = List.concat (map mk_tnames (list_upto num_prots))
val pnames =
let
val f = fn i => (Int.toString i,nth prots i)
val g = fn (i,(n,_)) => case n of NONE => i | SOME m => m
val h = fn s => mkN (pdefname,s)
in map (h o g o f) (list_upto num_prots)
end
val trtyp = prot_transactionT trac lthy
val trstyp = mk_listT trtyp
fun mk_prot_trm names =
Term.Const (@{const_name "concat"}, mk_listT trstyp --> trstyp) $
mk_list trstyp (map (fn x => Term.Const (x, trstyp)) names)
val lthy =
if num_prots > 1
then fold (fn (i,pname) => mk_prot_def (pname, mk_prot_trm (mk_tnames i)))
(map (fn i => (i, nth pnames i)) (list_upto num_prots))
lthy
else lthy
val pnames' = map (fn n => full_name n lthy) pnames
fun mk_prot_trm_with_star i =
let
fun f j =
if j = i
then Term.Const (nth pnames' j, trstyp)
else (Term.Const (@{const_name "map"}, [trtyp --> trtyp, trstyp] ---> trstyp) $
Term.Const ("Transactions.transaction_star_proj", trtyp --> trtyp) $
Term.Const (nth pnames' j, trstyp))
in
Term.Const (@{const_name "concat"}, mk_listT trstyp --> trstyp) $
mk_list trstyp (map f (list_upto num_prots))
end
val lthy =
if num_prots > 1
then fold (fn (i,pname) => mk_prot_def (pname, mk_prot_trm_with_star i))
(map (fn i => (i, nth pnames i ^ "_with_star")) (list_upto num_prots))
lthy
else lthy
in
mk_prot_def (pdefname, mk_prot_trm (if num_prots > 1 then pnames' else tnames)) lthy
end
in
(trac, lthy |> def_transactions |> def_protocols)
end
end
›
ML‹
structure trac = struct
open Trac_Term
val info = Output.information
type hide_tvar_tab = (TracProtocol.protocol) Symtab.table
fun trac_eq (a, a') = (#name a) = (#name a')
fun merge_trac_tab (tab,tab') = Symtab.merge trac_eq (tab,tab')
structure Data = Generic_Data
(
type T = hide_tvar_tab
val empty = Symtab.empty:hide_tvar_tab
val extend = I
fun merge(t1,t2) = merge_trac_tab (t1, t2)
);
fun update p thy = Context.theory_of
((Data.map (fn tab => Symtab.update (#name p, p) tab) (Context.Theory thy)))
fun lookup name thy = (Symtab.lookup ((Data.get o Context.Theory) thy) name,thy)
fun mk_abs_filename thy filename =
let
val filename = Path.explode filename
val master_dir = Resources.master_directory thy
in
Path.implode (if (Path.is_absolute filename)
then filename
else master_dir + filename)
end
fun lookup_trac (pname:string) lthy =
Option.valOf (fst (lookup pname (Proof_Context.theory_of lthy)))
fun def_fp fp_str print (trac, lthy) =
let
val fp = TracFpParser.parse_str fp_str
val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy
val lthy = Local_Theory.raw_theory (update trac) lthy
in
(trac, lthy)
end
fun def_fp_file filename print (trac, lthy) = let
val thy = Proof_Context.theory_of lthy
val abs_filename = mk_abs_filename thy filename
val fp = TracFpParser.parse_file abs_filename
val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy
val lthy = Local_Theory.raw_theory (update trac) lthy
in
(trac, lthy)
end
fun def_fp_trac fp_filename print (trac, lthy) = let
open OS.FileSys OS.Process
val _ = info("Checking protocol specification with trac.")
val thy = Proof_Context.theory_of lthy
val abs_filename = mk_abs_filename thy fp_filename
val fp_raw = File.read (Path.explode abs_filename)
val fp = TracFpParser.parse_str fp_raw
val _ = if TracFpParser.attack fp
then
error (" ATTACK found, skipping generating of Isabelle/HOL definitions.\n\n")
else
info(" No attack found, continue with generating Isabelle/HOL definitions.")
val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy
val lthy = Local_Theory.raw_theory (update trac) lthy
in
(trac, lthy)
end
fun def_trac_term_model str lthy = let
val trac = TracProtocolParser.parse_str str
val lthy = Local_Theory.raw_theory (update trac) lthy
val lthy = trac_definitorial_package.define_term_model trac lthy
in
(trac, lthy)
end
val def_trac_protocol = trac_definitorial_package.define_protocol
fun def_trac str print = def_trac_protocol print o def_trac_term_model str
fun def_trac_file filename print lthy = let
val trac_raw = File.read (Path.explode filename)
val (trac,lthy) = def_trac trac_raw print lthy
val lthy = Local_Theory.raw_theory (update trac) lthy
in
(trac, lthy)
end
fun def_trac_fp_trac trac_str print lthy = let
open OS.FileSys OS.Process
val (trac,lthy) = def_trac trac_str print lthy
val tmpname = tmpName()
val _ = File.write (Path.explode tmpname) trac_str
val (trac,lthy) = def_fp_trac tmpname print (trac, lthy)
val _ = OS.FileSys.remove tmpname
val lthy = Local_Theory.raw_theory (update trac) lthy
in
lthy
end
end
›
ML‹
val fileNameP = Parse.name -- Parse.name
val _ = Outer_Syntax.local_theory' @{command_keyword "trac_import"}
"Import protocol and fixpoint from trac files."
(fileNameP >> (fn (trac_filename, fp_filename) => fn print =>
trac.def_trac_file trac_filename print #>
trac.def_fp_file fp_filename print #> snd));
val _ = Outer_Syntax.local_theory' @{command_keyword "trac_import_trac"}
"Import protocol from trac file and compute fixpoint with trac."
(fileNameP >> (fn (trac_filename, fp_filename) => fn print =>
trac.def_trac trac_filename print #> trac.def_fp_trac fp_filename print #> snd));
val _ = Outer_Syntax.local_theory' @{command_keyword "trac_trac"}
"Define protocol using trac format and compute fixpoint with trac."
(Parse.cartouche >> (fn trac => fn print => trac.def_trac_fp_trac trac print));
val _ = Outer_Syntax.local_theory' @{command_keyword "trac"}
"Define protocol and (optionally) fixpoint using trac format."
(Parse.cartouche -- Scan.optional Parse.cartouche "" >> (fn (trac,fp) => fn print =>
if fp = ""
then trac.def_trac trac print #> snd
else trac.def_trac trac print #> trac.def_fp fp print #> snd));
›
ML‹
val name_prefix_parser = Parse.!!! (Parse.name --| Parse.$$$ ":" -- Parse.name)
val opt_proof_method_choice =
Scan.optional (\<^keyword>‹[› |-- Parse.name --| \<^keyword>‹]›) "safe";
val opt_defs_list = Scan.optional
(\<^keyword>‹for› |-- Scan.repeat1 Parse.name >>
(fn xs => if length xs > 3 then error "Too many optional arguments" else xs))
[];
val security_proof_locale_parser =
name_prefix_parser -- opt_defs_list
val security_proof_locale_parser_with_method_choice =
opt_proof_method_choice -- name_prefix_parser -- opt_defs_list
fun protocol_model_setup_proof_state name prefix lthy =
let
fun f x y z = ([((x,Position.none),((y,true),(Expression.Positional z,[])))],[])
val _ = if name = "" then error "No name given" else ()
val pexpr = f "stateful_protocol_model" name (protocol_model_interpretation_params prefix)
val pdefs = protocol_model_interpretation_defs name
val proof_state = Interpretation.global_interpretation_cmd pexpr pdefs lthy
in
proof_state
end
fun protocol_security_proof_proof_state manual_proof name prefix opt_defs print lthy =
let
fun f x y z = ([((x,Position.none),((y,true),(Expression.Positional z,[])))],[])
val _ = if name = "" then error "No name given" else ()
val num_defs = length opt_defs
val pparams = protocol_model_interpretation_params prefix
val default_defs = [prefix ^ "_" ^ "protocol", prefix ^ "_" ^ "fixpoint"]
fun g locale_name extra_params = f locale_name name (pparams@map SOME extra_params)
val (prot_fp_smp_names, pexpr) = if manual_proof
then (case num_defs of
0 => (default_defs, g "secure_stateful_protocol'" default_defs)
| 1 => (opt_defs, g "secure_stateful_protocol''" opt_defs)
| 2 => (opt_defs, g "secure_stateful_protocol'" opt_defs)
| _ => (opt_defs, g "secure_stateful_protocol" opt_defs))
else (case num_defs of
0 => (default_defs, g "secure_stateful_protocol''''" default_defs)
| 1 => (opt_defs, g "secure_stateful_protocol''" opt_defs)
| 2 => (opt_defs, g "secure_stateful_protocol''''" opt_defs)
| _ => (opt_defs, g "secure_stateful_protocol'''" opt_defs))
val proof_state = lthy |> declare_protocol_checks print
|> Interpretation.global_interpretation_cmd pexpr []
in
(prot_fp_smp_names, proof_state)
end
val _ =
Outer_Syntax.local_theory \<^command_keyword>‹protocol_model_setup›
"prove interpretation of protocol model locale into global theory"
(name_prefix_parser >> (fn (name,prefix) => fn lthy =>
let
val proof_state = protocol_model_setup_proof_state name prefix lthy
val meth =
let
val m = "protocol_model_interpretation"
val _ = Output.information (
"Proving protocol model locale instance with proof method " ^ m)
in
Method.Source (Token.make_src (m, Position.none) [])
end
in
ml_isar_wrapper.prove_state_simple meth proof_state
end));
val _ =
Outer_Syntax.local_theory_to_proof \<^command_keyword>‹manual_protocol_model_setup›
"prove interpretation of protocol model locale into global theory"
(name_prefix_parser >> (fn (name,prefix) => fn lthy =>
let
val proof_state = protocol_model_setup_proof_state name prefix lthy
val subgoal_proof = " subgoal by protocol_model_subgoal\n"
val _ = Output.information ("Example proof:\n" ^
Active.sendback_markup_command (" apply unfold_locales\n"^
subgoal_proof^
subgoal_proof^
subgoal_proof^
subgoal_proof^
subgoal_proof^
" done\n"))
in
proof_state
end));
val _ =
Outer_Syntax.local_theory' \<^command_keyword>‹protocol_security_proof›
"prove interpretation of secure protocol locale into global theory"
(security_proof_locale_parser_with_method_choice >> (fn params => fn print => fn lthy =>
let
val ((opt_meth_level,(name,prefix)),opt_defs) = params
val (defs, proof_state) =
protocol_security_proof_proof_state false name prefix opt_defs print lthy
val num_defs = length defs
val meth =
let
val m = case opt_meth_level of
"safe" => "check_protocol" ^ "'"
| "unsafe" => "check_protocol_unsafe" ^ "'"
| _ => error ("Invalid option: " ^ opt_meth_level)
val _ = Output.information (
"Proving security of protocol " ^ nth defs 0 ^ " with proof method " ^ m)
val _ = if num_defs > 1 then Output.information ("Using fixpoint " ^ nth defs 1) else ()
val _ = if num_defs > 2 then Output.information ("Using SMP set " ^ nth defs 2) else ()
in
Method.Source (Token.make_src (m, Position.none) [])
end
in
ml_isar_wrapper.prove_state_simple meth proof_state
end
));
val _ =
Outer_Syntax.local_theory_to_proof' \<^command_keyword>‹manual_protocol_security_proof›
"prove interpretation of secure protocol locale into global theory"
(security_proof_locale_parser >> (fn params => fn print => fn lthy =>
let
val ((name,prefix),opt_defs) = params
val (defs, proof_state) =
protocol_security_proof_proof_state true name prefix opt_defs print lthy
val subgoal_proof =
let
val m = "code_simp"
in
" subgoal by " ^ m ^ "\n"
end
val _ = Output.information ("Example proof:\n" ^
Active.sendback_markup_command (" apply check_protocol_intro\n"^
subgoal_proof^
(if length defs = 1 then ""
else subgoal_proof^
subgoal_proof^
subgoal_proof^
subgoal_proof)^
" done\n"))
in
proof_state
end
));
›
end
Theory Keyserver
section‹The Keyserver Protocol›
theory Keyserver
imports "../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: keyserver
Types:
honest = {a,b,c}
server = {s}
agents = honest ++ server
Sets:
ring/1 valid/2 revoked/2
Functions:
Public sign/2 crypt/2 pair/2
Private inv/1
Analysis:
sign(X,Y) -> Y
crypt(X,Y) ? inv(X) -> Y
pair(X,Y) -> X,Y
Transactions:
# Out-of-band registration
outOfBand(A:honest,S:server)
new NPK
insert NPK ring(A)
insert NPK valid(A,S)
send NPK.
# User update key
keyUpdateUser(A:honest,PK:value)
PK in ring(A)
new NPK
delete PK ring(A)
insert NPK ring(A)
send sign(inv(PK),pair(A,NPK)).
# Server update key
keyUpdateServer(A:honest,S:server,PK:value,NPK:value)
receive sign(inv(PK),pair(A,NPK))
PK in valid(A,S)
NPK notin valid(_)
NPK notin revoked(_)
delete PK valid(A,S)
insert PK revoked(A,S)
insert NPK valid(A,S)
send inv(PK).
# Attack definition
authAttack(A:honest,S:server,PK:value)
receive inv(PK)
PK in valid(A,S)
attack.
›‹
val(ring(A)) where A:honest
sign(inv(val(0)),pair(A,val(ring(A)))) where A:honest
inv(val(revoked(A,S))) where A:honest S:server
pair(A,val(ring(A))) where A:honest
occurs(val(ring(A))) where A:honest
timplies(val(ring(A)),val(ring(A),valid(A,S))) where A:honest S:server
timplies(val(ring(A)),val(0)) where A:honest
timplies(val(ring(A),valid(A,S)),val(valid(A,S))) where A:honest S:server
timplies(val(0),val(valid(A,S))) where A:honest S:server
timplies(val(valid(A,S)),val(revoked(A,S))) where A:honest S:server
›
subsection ‹Proof of security›
protocol_model_setup spm: keyserver
compute_SMP [optimized] keyserver_protocol keyserver_SMP
manual_protocol_security_proof ssp: keyserver
for keyserver_protocol keyserver_fixpoint keyserver_SMP
apply check_protocol_intro
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
done
end
Theory Keyserver2
section‹A Variant of the Keyserver Protocol›
theory Keyserver2
imports "../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: keyserver2
Types:
honest = {a,b,c}
dishonest = {i}
agent = honest ++ dishonest
Sets:
ring'/1 seen/1 pubkeys/0 valid/1
Functions:
Public h/1 sign/2 crypt/2 scrypt/2 pair/2 update/3
Private inv/1 pw/1
Analysis:
sign(X,Y) -> Y
crypt(X,Y) ? inv(X) -> Y
scrypt(X,Y) ? X -> Y
pair(X,Y) -> X,Y
update(X,Y,Z) -> X,Y,Z
Transactions:
passwordGenD(A:dishonest)
send pw(A).
pubkeysGen()
new PK
insert PK pubkeys
send PK.
updateKeyPw(A:honest,PK:value)
PK in pubkeys
new NPK
insert NPK ring'(A)
send NPK
send crypt(PK,update(A,NPK,pw(A))).
updateKeyServerPw(A:agent,PK:value,NPK:value)
receive crypt(PK,update(A,NPK,pw(A)))
PK in pubkeys
NPK notin pubkeys
NPK notin seen(_)
insert NPK valid(A)
insert NPK seen(A).
authAttack2(A:honest,PK:value)
receive inv(PK)
PK in valid(A)
attack.
›
subsection ‹Proof of security ›
protocol_model_setup spm: keyserver2
compute_fixpoint keyserver2_protocol keyserver2_fixpoint
protocol_security_proof ssp: keyserver2
subsection ‹The generated theorems and definitions›
thm ssp.protocol_secure
thm keyserver2_enum_consts.nchotomy
thm keyserver2_sets.nchotomy
thm keyserver2_fun.nchotomy
thm keyserver2_atom.nchotomy
thm keyserver2_arity.simps
thm keyserver2_public.simps
thm keyserver2_Γ.simps
thm keyserver2_Ana.simps
thm keyserver2_transaction_passwordGenD_def
thm keyserver2_transaction_pubkeysGen_def
thm keyserver2_transaction_updateKeyPw_def
thm keyserver2_transaction_updateKeyServerPw_def
thm keyserver2_transaction_authAttack2_def
thm keyserver2_protocol_def
thm keyserver2_fixpoint_def
end
Theory Keyserver_Composition
section‹The Composition of the Two Keyserver Protocols›
theory Keyserver_Composition
imports "../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: kscomp
Types:
honest = {a,b,c}
dishonest = {i}
agent = honest ++ dishonest
Sets:
ring/1 valid/1 revoked/1 deleted/1
ring'/1 seen/1 pubkeys/0
Functions:
Public h/1 sign/2 crypt/2 scrypt/2 pair/2 update/3
Private inv/1 pw/1
Analysis:
sign(X,Y) -> Y
crypt(X,Y) ? inv(X) -> Y
scrypt(X,Y) ? X -> Y
pair(X,Y) -> X,Y
update(X,Y,Z) -> X,Y,Z
Transactions:
### The signature-based keyserver protocol
p1_outOfBand(A:honest)
new PK
insert PK ring(A)
* insert PK valid(A)
send PK.
p1_oufOfBandD(A:dishonest)
new PK
* insert PK valid(A)
send PK
send inv(PK).
p1_updateKey(A:honest,PK:value)
PK in ring(A)
new NPK
delete PK ring(A)
insert PK deleted(A)
insert NPK ring(A)
send sign(inv(PK),pair(A,NPK)).
p1_updateKeyServer(A:agent,PK:value,NPK:value)
receive sign(inv(PK),pair(A,NPK))
* PK in valid(A)
* NPK notin valid(_)
NPK notin revoked(_)
* delete PK valid(A)
insert PK revoked(A)
* insert NPK valid(A)
send inv(PK).
p1_authAttack(A:honest,PK:value)
receive inv(PK)
* PK in valid(A)
attack.
### The password-based keyserver protocol
p2_passwordGenD(A:dishonest)
send pw(A).
p2_pubkeysGen()
new PK
insert PK pubkeys
send PK.
p2_updateKeyPw(A:honest,PK:value)
PK in pubkeys
new NPK
# NOTE: The ring' sets are not used elsewhere, but we have to avoid that the fresh keys generated
# by this rule are abstracted to the empty abstraction, and so we insert them into a ring'
# set. Otherwise the two protocols would have too many abstractions in common (in particular,
# the empty abstraction) which leads to false attacks in the composed protocol (probably
# because the term implication graphs of the two protocols then become 'linked' through the
# empty abstraction)
insert NPK ring'(A)
send NPK
send crypt(PK,update(A,NPK,pw(A))).
#Transactions of p2:
p2_updateKeyServerPw(A:agent,PK:value,NPK:value)
receive crypt(PK,update(A,NPK,pw(A)))
PK in pubkeys
NPK notin pubkeys
NPK notin seen(_)
* insert NPK valid(A)
insert NPK seen(A).
p2_authAttack2(A:honest,PK:value)
receive inv(PK)
* PK in valid(A)
attack.
› ‹
sign(inv(val(deleted(A))),pair(A,val(ring(A)))) where A:honest
sign(inv(val(deleted(A),valid(B))),pair(A,val(ring(A)))) where A:honest B:dishonest
sign(inv(val(deleted(A),seen(B),valid(B))),pair(A,val(ring(A)))) where A:honest B:dishonest
sign(inv(val(deleted(A),valid(A))),pair(A,val(ring(A)))) where A:honest B:dishonest
sign(inv(val(deleted(A),seen(B),valid(B),valid(A))),pair(A,val(ring(A)))) where A:honest B:dishonest
pair(A,val(ring(A))) where A:honest
inv(val(deleted(A),revoked(A))) where A:honest
inv(val(valid(A))) where A:dishonest
inv(val(revoked(A))) where A:dishonest
inv(val(revoked(A),seen(A))) where A:dishonest
inv(val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
inv(val(revoked(A),deleted(A),seen(B),valid(B))) where A:honest B:dishonest
occurs(val(ring(A))) where A:honest
occurs(val(valid(A))) where A:dishonest
occurs(val(ring'(A))) where A:honest
occurs(val(pubkeys))
occurs(val(valid(A),ring(A))) where A:honest
pw(A) where A:dishonest
crypt(val(pubkeys),update(A,val(ring'(A)),pw(A))) where A:honest
val(ring(A)) where A:honest
val(valid(A)) where A:dishonest
val(ring'(A)) where A:honest
val(pubkeys)
val(valid(A),ring(A)) where A:honest
timplies(val(pubkeys),val(valid(A),pubkeys)) where A:dishonest
timplies(val(ring'(A)),val(ring'(A),valid(B))) where A:honest B:dishonest
timplies(val(ring'(A)),val(ring'(A),valid(A),seen(A))) where A:honest
timplies(val(ring'(A)),val(ring'(A),valid(A),seen(A),valid(B))) where A:honest B:dishonest
timplies(val(ring'(A)),val(seen(B),valid(B),ring'(A))) where A:honest B:dishonest
timplies(val(ring'(A),valid(B)),val(ring'(A),valid(A),seen(A),valid(B))) where A:honest B:dishonest
timplies(val(ring'(A),valid(B)),val(seen(B),valid(B),ring'(A))) where A:honest B:dishonest
timplies(val(ring(A)),val(ring(A),valid(A))) where A:honest
timplies(val(ring(A)),val(ring(A),valid(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(deleted(A))) where A:honest
timplies(val(ring(A)),val(revoked(A),deleted(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(revoked(A),deleted(A),seen(B),revoked(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(deleted(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(ring(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(valid(A),deleted(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A)),val(valid(A),ring(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A),valid(A)),val(deleted(A),valid(A))) where A:honest
timplies(val(ring(A),valid(B)),val(deleted(A),valid(B))) where A:honest B:dishonest
timplies(val(ring(A),valid(A)),val(deleted(A),revoked(A))) where A:honest
timplies(val(deleted(A)),val(deleted(A),valid(A))) where A:honest
timplies(val(deleted(A)),val(deleted(A),valid(B))) where A:honest B:dishonest
timplies(val(deleted(A)),val(revoked(A),seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(deleted(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(deleted(A)),val(seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(deleted(A)),val(seen(B),valid(B),valid(A),deleted(A))) where A:honest B:dishonest
timplies(val(revoked(A)),val(seen(A),revoked(A))) where A:dishonest
timplies(val(revoked(A)),val(seen(A),revoked(A),valid(A))) where A:dishonest
timplies(val(revoked(A),deleted(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(revoked(A),deleted(A)),val(seen(B),valid(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),deleted(A),valid(A)),val(revoked(A),seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),deleted(A),valid(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),revoked(A),deleted(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(seen(A),valid(A)),val(revoked(A),seen(A))) where A:dishonest
timplies(val(seen(A),valid(A),revoked(A)),val(seen(A),revoked(A))) where A:dishonest
timplies(val(seen(B),valid(B),ring(A)),val(deleted(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),valid(A),ring(A)),val(deleted(A),seen(B),valid(B),valid(A))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),valid(A),ring(A)),val(revoked(A),seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(seen(B),valid(B),valid(A),ring(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(valid(A)),val(revoked(A))) where A:dishonest
timplies(val(valid(A),deleted(A)),val(deleted(A),revoked(A))) where A:honest
timplies(val(valid(A),deleted(A)),val(revoked(A),seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(valid(A),deleted(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(valid(A),deleted(A)),val(seen(B),valid(B),valid(A),deleted(A))) where A:honest B:dishonest
timplies(val(ring(A),valid(A)),val(deleted(A),seen(B),valid(B),valid(A))) where A:honest B:dishonest
timplies(val(ring(A),valid(A)),val(revoked(B),seen(B),revoked(A),deleted(A))) where A:honest B:dishonest
timplies(val(ring(A),valid(A)),val(seen(B),valid(B),valid(A),ring(A))) where A:honest B:dishonest
timplies(val(valid(B),deleted(A)),val(seen(B),valid(B),deleted(A))) where A:honest B:dishonest
timplies(val(ring(A),valid(B)),val(deleted(A),seen(B),valid(B))) where A:honest B:dishonest
timplies(val(ring(A),valid(B)),val(seen(B),valid(B),ring(A))) where A:honest B:dishonest
timplies(val(valid(A)),val(seen(A),valid(A))) where A:dishonest
›
subsection ‹Proof: The composition of the two keyserver protocols is secure›
protocol_model_setup spm: kscomp
setup_protocol_checks spm kscomp_protocol
manual_protocol_security_proof ssp: kscomp
apply check_protocol_intro
subgoal by code_simp
subgoal
apply coverage_check_intro
subgoal by code_simp
subgoal by code_simp
subgoal by eval
subgoal by eval
subgoal by eval
subgoal by code_simp
subgoal by code_simp
subgoal by eval
subgoal by eval
subgoal by eval
done
subgoal by eval
subgoal by eval
subgoal
apply (unfold spm.wellformed_fixpoint_def Let_def case_prod_unfold; intro conjI)
subgoal by code_simp
subgoal by code_simp
subgoal by eval
subgoal by code_simp
subgoal by code_simp
done
done
subsection ‹The generated theorems and definitions›
thm ssp.protocol_secure
thm kscomp_enum_consts.nchotomy
thm kscomp_sets.nchotomy
thm kscomp_fun.nchotomy
thm kscomp_atom.nchotomy
thm kscomp_arity.simps
thm kscomp_public.simps
thm kscomp_Γ.simps
thm kscomp_Ana.simps
thm kscomp_transaction_p1_outOfBand_def
thm kscomp_transaction_p1_oufOfBandD_def
thm kscomp_transaction_p1_updateKey_def
thm kscomp_transaction_p1_updateKeyServer_def
thm kscomp_transaction_p1_authAttack_def
thm kscomp_transaction_p2_passwordGenD_def
thm kscomp_transaction_p2_pubkeysGen_def
thm kscomp_transaction_p2_updateKeyPw_def
thm kscomp_transaction_p2_updateKeyServerPw_def
thm kscomp_transaction_p2_authAttack2_def
thm kscomp_protocol_def
thm kscomp_fixpoint_def
end
Theory PKCS_Model03
section‹The PKCS Model, Scenario 3›
theory PKCS_Model03
imports "../../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: ATTACK_UNSET
Types:
token = {token1}
Sets:
extract/1 wrap/1 decrypt/1 sensitive/1
Functions:
Public senc/2 h/1
Private inv/1
Analysis:
senc(M,K2) ? K2 -> M #This analysis rule corresponds to the decrypt2 rule in the AIF-omega specification.
#M was type untyped
Transactions:
iik1()
new K1
insert K1 sensitive(token1)
insert K1 extract(token1)
send h(K1).
iik2()
new K2
insert K2 wrap(token1)
send h(K2).
# ======================wrap================
wrap(K1:value,K2:value)
receive h(K1)
receive h(K2)
K1 in extract(token1)
K2 in wrap(token1)
send senc(K1,K2).
# ======================set wrap================
setwrap(K2:value)
receive h(K2)
K2 notin decrypt(token1)
insert K2 wrap(token1).
# ======================set decrypt================
setdecrypt(K2:value)
receive h(K2)
K2 notin wrap(token1)
insert K2 decrypt(token1).
# ======================decrypt================
decrypt1(K2:value,M:value) #M was untyped in the AIF-omega specification.
receive h(K2)
receive senc(M,K2)
K2 in decrypt(token1)
send M.
# ======================attacks================
attack1(K1:value)
receive K1
K1 in sensitive(token1)
attack.
›
subsection ‹Protocol model setup›
protocol_model_setup spm: ATTACK_UNSET
subsection ‹Fixpoint computation›
compute_fixpoint ATTACK_UNSET_protocol ATTACK_UNSET_fixpoint
compute_SMP [optimized] ATTACK_UNSET_protocol ATTACK_UNSET_SMP
subsection ‹Proof of security›
manual_protocol_security_proof ssp: ATTACK_UNSET
for ATTACK_UNSET_protocol ATTACK_UNSET_fixpoint ATTACK_UNSET_SMP
apply check_protocol_intro
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
subgoal by code_simp
done
subsection ‹The generated theorems and definitions›
thm ssp.protocol_secure
thm ATTACK_UNSET_enum_consts.nchotomy
thm ATTACK_UNSET_sets.nchotomy
thm ATTACK_UNSET_fun.nchotomy
thm ATTACK_UNSET_atom.nchotomy
thm ATTACK_UNSET_arity.simps
thm ATTACK_UNSET_public.simps
thm ATTACK_UNSET_Γ.simps
thm ATTACK_UNSET_Ana.simps
thm ATTACK_UNSET_transaction_iik1_def
thm ATTACK_UNSET_transaction_iik2_def
thm ATTACK_UNSET_transaction_wrap_def
thm ATTACK_UNSET_transaction_setwrap_def
thm ATTACK_UNSET_transaction_setdecrypt_def
thm ATTACK_UNSET_transaction_decrypt1_def
thm ATTACK_UNSET_transaction_attack1_def
thm ATTACK_UNSET_protocol_def
thm ATTACK_UNSET_fixpoint_def
thm ATTACK_UNSET_SMP_def
end
Theory PKCS_Model07
section‹The PKCS Protocol, Scenario 7›
theory PKCS_Model07
imports "../../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: RE_IMPORT_ATT
Types:
token = {token1}
Sets:
extract/1 wrap/1 unwrap/1 decrypt/1 sensitive/1
Functions:
Public senc/2 h/2 bind/2
Private inv/1
Analysis:
senc(M1,K2) ? K2 -> M1 #This analysis rule corresponds to the decrypt2 rule in the AIF-omega specification.
#M1 was type untyped
Transactions:
iik1()
new K1
new N1
insert N1 sensitive(token1)
insert N1 extract(token1)
insert K1 sensitive(token1)
send h(N1,K1).
iik2()
new K2
new N2
insert N2 wrap(token1)
insert N2 extract(token1)
send h(N2,K2).
# =====set wrap=====
setwrap(N2:value,K2:value)
receive h(N2,K2)
N2 notin sensitive(token1)
N2 notin decrypt(token1)
insert N2 wrap(token1).
# =====set unwrap===
setunwrap(N2:value,K2:value)
receive h(N2,K2)
N2 notin sensitive(token1)
insert N2 unwrap(token1).
# =====unwrap, generate new handler======
#-----------the senstive attr copy-------------
unwrapsensitive(M2:value, K2:value, N1:value, N2:value) #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2)
receive h(N2,K2)
N1 in sensitive(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew sensitive(token1)
send h(Nnew,M2).
#-----------the wrap attr copy-------------
wrapattr(M2:value, K2:value, N1:value, N2:value) #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2)
receive h(N2,K2)
N1 in wrap(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew wrap(token1)
send h(Nnew,M2).
#-----------the decrypt attr copy-------------
decrypt1attr(M2:value,K2:value,N1:value,N2:value) #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2)
receive h(N2,K2)
N1 in decrypt(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew decrypt(token1)
send h(Nnew,M2).
decrypt2attr(M2:value,K2:value,N1:value,N2:value) #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2)
receive h(N2,K2)
N1 notin sensitive(token1)
N1 notin wrap(token1)
N1 notin decrypt(token1)
N2 in unwrap(token1)
new Nnew
send h(Nnew,M2).
# ======================wrap================
wrap(N1:value,K1:value,N2:value,K2:value)
receive h(N1,K1)
receive h(N2,K2)
N1 in extract(token1)
N2 in wrap(token1)
send senc(K1,K2)
send bind(N1,K1).
# =====set decrypt===
setdecrypt(Nnew:value, K2:value)
receive h(Nnew,K2)
Nnew notin wrap(token1)
insert Nnew decrypt(token1).
# ======================decrypt================
decrypt1(Nnew:value, K2:value,M1:value) #M1 was untyped in the AIF-omega specification.
receive h(Nnew,K2)
receive senc(M1,K2)
Nnew in decrypt(token1)
delete Nnew decrypt(token1)
send M1.
# ======================attacks================
attack1(K1:value)
receive K1
K1 in sensitive(token1)
attack.
›
subsection ‹Protocol model setup›
protocol_model_setup spm: RE_IMPORT_ATT
subsection ‹Fixpoint computation›
compute_fixpoint RE_IMPORT_ATT_protocol RE_IMPORT_ATT_fixpoint
compute_SMP [optimized] RE_IMPORT_ATT_protocol RE_IMPORT_ATT_SMP
subsection ‹Proof of security›
protocol_security_proof [unsafe] ssp: RE_IMPORT_ATT
for RE_IMPORT_ATT_protocol RE_IMPORT_ATT_fixpoint RE_IMPORT_ATT_SMP
subsection ‹The generated theorems and definitions›
thm ssp.protocol_secure
thm RE_IMPORT_ATT_enum_consts.nchotomy
thm RE_IMPORT_ATT_sets.nchotomy
thm RE_IMPORT_ATT_fun.nchotomy
thm RE_IMPORT_ATT_atom.nchotomy
thm RE_IMPORT_ATT_arity.simps
thm RE_IMPORT_ATT_public.simps
thm RE_IMPORT_ATT_Γ.simps
thm RE_IMPORT_ATT_Ana.simps
thm RE_IMPORT_ATT_transaction_iik1_def
thm RE_IMPORT_ATT_transaction_iik2_def
thm RE_IMPORT_ATT_transaction_setwrap_def
thm RE_IMPORT_ATT_transaction_setunwrap_def
thm RE_IMPORT_ATT_transaction_unwrapsensitive_def
thm RE_IMPORT_ATT_transaction_wrapattr_def
thm RE_IMPORT_ATT_transaction_decrypt1attr_def
thm RE_IMPORT_ATT_transaction_decrypt2attr_def
thm RE_IMPORT_ATT_transaction_wrap_def
thm RE_IMPORT_ATT_transaction_setdecrypt_def
thm RE_IMPORT_ATT_transaction_decrypt1_def
thm RE_IMPORT_ATT_transaction_attack1_def
thm RE_IMPORT_ATT_protocol_def
thm RE_IMPORT_ATT_fixpoint_def
thm RE_IMPORT_ATT_SMP_def
end
Theory PKCS_Model09
section‹The PKCS Protocol, Scenario 9›
theory PKCS_Model09
imports "../../PSPSP"
begin
declare [[code_timing]]
trac‹
Protocol: LOSS_KEY_ATT
Types:
token = {token1}
Sets:
extract/1 wrap/1 unwrap/1 decrypt/1 sensitive/1
Functions:
Public senc/2 h/2 bind/3
Private inv/1
Analysis:
senc(M1,K2) ? K2 -> M1 #This analysis rule corresponds to the decrypt2 rule in the AIF-omega specification.
#M1 was type untyped
Transactions:
iik1()
new K1
new N1
insert N1 sensitive(token1)
insert N1 extract(token1)
insert K1 sensitive(token1)
send h(N1,K1).
iik2()
new K2
new N2
insert N2 wrap(token1)
insert N2 extract(token1)
send h(N2,K2).
iik3()
new K3
new N3
insert N3 extract(token1)
insert N3 decrypt(token1)
insert K3 decrypt(token1)
send h(N3,K3)
send K3.
# =====set wrap=====
setwrap(N2:value,K2:value) where N2 != K2
receive h(N2,K2)
N2 notin sensitive(token1)
N2 notin decrypt(token1)
insert N2 wrap(token1).
# =====set unwrap===
setunwrap(N2:value,K2:value) where N2 != K2
receive h(N2,K2)
N2 notin sensitive(token1)
insert N2 unwrap(token1).
# =====unwrap, generate new handler======
#-----------add the wrap attr copy-------------
unwrapWrap(M2:value,K2:value,N1:value,N2:value) where M2 != K2, M2 != N1, M2 != N2, K2 != N1, K2 != N2, N1 != N2 #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2,K2)
receive h(N2,K2)
N1 in wrap(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew wrap(token1)
send h(Nnew,M2).
#-----------add the senstive attr copy-------------
unwrapSens(M2:value,K2:value,N1:value,N2:value) where M2 != K2, M2 != N1, M2 != N2, K2 != N1, K2 != N2, N1 != N2 #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2,K2)
receive h(N2,K2)
N1 in sensitive(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew sensitive(token1)
send h(Nnew,M2).
#-----------add the decrypt attr copy-------------
decrypt1Attr(M2:value, K2:value,N1:value,N2:value) where M2 != K2, M2 != N1, M2 != N2, K2 != N1, K2 != N2, N1 != N2 #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2,K2)
receive h(N2,K2)
N1 in decrypt(token1)
N2 in unwrap(token1)
new Nnew
insert Nnew decrypt(token1)
send h(Nnew,M2).
decrypt2Attr(M2:value, K2:value,N1:value,N2:value) where M2 != K2, M2 != N1, M2 != N2, K2 != N1, K2 != N2, N1 != N2 #M2 was untyped in the AIF-omega specification.
receive senc(M2,K2)
receive bind(N1,M2,K2)
receive h(N2,K2)
N1 notin wrap(token1)
N1 notin sensitive(token1)
N1 notin decrypt(token1)
N2 in unwrap(token1)
new Nnew
send h(Nnew,M2).
# ======================wrap================
wrap(N1:value,K1:value, N2:value, K2:value) where N1 != N2, N1 != K2, N1 != K1, N2 != K2, N2 != K1, K2 != K1
receive h(N1,K1)
receive h(N2,K2)
N1 in extract(token1)
N2 in wrap(token1)
send senc(K1,K2)
send bind(N1,K1,K2).
# ======================bind generation================
bind1(K3:value,N2:value,K2:value, K1:value) where K3 != N2, K3 != K2, K3 != K1, N2 != K2, N2 != K1, K2 != K1
receive K3
receive h(N2,K2)
send bind(N2,K3,K3).
bind2(K3:value,N2:value,K2:value, K1:value) where K3 != N2, K3 != K2, K3 != K1, N2 != K2, N2 != K1, K2 != K1
receive K3
receive K1
receive h(N2,K2)
send bind(N2,K1,K3)
send bind(N2,K3,K1).
# =====set decrypt===
setdecrypt(Nnew:value,K2:value) where Nnew != K2
receive h(Nnew,K2)
Nnew notin wrap(token1)
insert Nnew decrypt(token1).
# ======================decrypt================
decrypt1(Nnew:value,K2:value,M1:value) where Nnew != K2, Nnew != M1, K2 != M1 #M1 was untyped in the AIF-omega specification.
receive h(Nnew,K2)
receive senc(M1,K2)
Nnew in decrypt(token1)
send M1.
# ======================attacks================
attack1(K1:value)
receive K1
K1 in sensitive(token1)
attack.
›
subsection ‹Protocol model setup›
protocol_model_setup spm: LOSS_KEY_ATT
subsection ‹Fixpoint computation›
compute_fixpoint LOSS_KEY_ATT_protocol LOSS_KEY_ATT_fixpoint
text ‹The fixpoint contains an attack signal›
value "attack_notin_fixpoint LOSS_KEY_ATT_fixpoint"
subsection ‹The generated theorems and definitions›
thm LOSS_KEY_ATT_enum_consts.nchotomy
thm LOSS_KEY_ATT_sets.nchotomy
thm LOSS_KEY_ATT_fun.nchotomy
thm LOSS_KEY_ATT_atom.nchotomy
thm LOSS_KEY_ATT_arity.simps
thm LOSS_KEY_ATT_public.simps
thm LOSS_KEY_ATT_Γ.simps
thm LOSS_KEY_ATT_Ana.simps
thm LOSS_KEY_ATT_transaction_iik1_def
thm LOSS_KEY_ATT_transaction_iik2_def
thm LOSS_KEY_ATT_transaction_iik3_def
thm LOSS_KEY_ATT_transaction_setwrap_def
thm LOSS_KEY_ATT_transaction_setunwrap_def
thm LOSS_KEY_ATT_transaction_unwrapWrap_def
thm LOSS_KEY_ATT_transaction_unwrapSens_def
thm LOSS_KEY_ATT_transaction_decrypt1Attr_def
thm LOSS_KEY_ATT_transaction_decrypt2Attr_def
thm LOSS_KEY_ATT_transaction_wrap_def
thm LOSS_KEY_ATT_transaction_bind1_def
thm LOSS_KEY_ATT_transaction_bind2_def
thm LOSS_KEY_ATT_transaction_setdecrypt_def
thm LOSS_KEY_ATT_transaction_decrypt1_def
thm LOSS_KEY_ATT_transaction_attack1_def
thm LOSS_KEY_ATT_protocol_def
thm LOSS_KEY_ATT_fixpoint_def
end